perm filename POINTY.SAI[HAL,HE]4 blob
sn#239533 filedate 1976-09-29 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00031 PAGES
C REC PAGE DESCRIPTION
C0000100001
C00004 00002 BEGIN "POINTY"
C00007 00003 ! Macros to communicate with Handy and invoke Wave functions
C00011 00004 ! Procedures to handle blue arm
C00012 00005 ! cursor & arithmetic stack definition
C00016 00006 ! stack operations
C00020 00007 ! symbol table routines
C00023 00008 ! abort
C00025 00009 ! new_node, unlnk_node, is_ancestor, lnk_node, copy_tree, controlled_by
C00029 00010 ! purge_id, fix_id
C00030 00011 ! some arithmetic on transform matrices
C00037 00012 ! arithmetic ops: tr,apush,apop,atop,tmul,tinv,tedit,oops
C00044 00013 ! some arithmetic on vectors
C00060 00014 ! absxf, setabsxf, absxfe
C00062 00015 ! afx_node
C00063 00016 ! node_csr, id_decode, nodespec, λ
C00066 00017 ! editing ops: mk_node, copy_node, name_node
C00068 00018 ! editing ops: affix_node, rigid, nonrigid, independent, merge
C00070 00019 ! editing ops: kill, unkill
C00072 00020 ! editing ops: godad,goson,elder,younger
C00074 00021 ! editing ops: cpush, cpop, ctop, cexch, crollup, crolldown
C00076 00022 ! editing ops: absloc, relloc, absset, relset
C00079 00023 ! motion operations
C00090 00024 ! macro operations for motion, pointit, grabbit, fdef
C00091 00025 ! altrans,alid, aldecs, unique_id
C00097 00026 ! code to emit a pointy command file
C00101 00027 ! dskin, macro routines, prompt, bcall
C00109 00028 ! tree_string, csr_string, astk_string
C00115 00029 ! display routines: tree_print,csr_print,update
C00119 00030 ! toplevel
C00121 00031 ! main program
C00123 ENDMK
C⊗;
BEGIN "POINTY"
REQUIRE "ABBREV.SAI[S,RHT]" SOURCE_FILE;
REQUIRE "MACROS.SAI[S,RHT]" SOURCE_FILE;
IFCR NOT DECLARATION(BVERS) THENC DEFINE BVERS=TRUE; ENDC
IFCR NOT DECLARATION(YVERS) THENC DEFINE YVERS=NOT BVERS; ENDC
IFCR YVERS THENC
REQUIRE "YELLOW ARM VERSION" MESSAGE;
REQUIRE "PREAMB.SAI[SYS,HE]" SOURCE_FILE;
ENDC
IFCR BVERS THENC
REQUIRE "BLUE ARM VERSION" MESSAGE;
ENDC
REQUIRE "RECAUX.HDR[S,RHT]" SOURCE_FILE;
REQUIRE "DPYSUB.HDR[1,PDQ]" SOURCE_FILE;
FORWARD PROCEDURE ABORT(STRING MSG);
RCLASS NODE(STRING PNAME;RANY DAD,SON,EBRO,YBRO;
INTEGER HOWLINKED;
REAL ARRAY XF);
! XF[1:3,1:3] = rotation matrix.
XF[1:3,4] = translation vector.
XF[4,1:3] = 0.
XF[4,4] = 1.0.
XF[5,1:3] = rotation angles.
XF[5,4] > 0 if angles are valid.
;
RCLASS XFELT(REAL ARRAY XF);
RCLASS VECTOR(REAL X,Y,Z);
RCLASS SCALAR(REAL VAL);
FORWARD RPTR(XFELT) PROCEDURE NEW_XFELT;
DEFINE INDLNK = 0; ! independent;
DEFINE NRGLNK = 1; ! non-rigid affixment;
DEFINE RGDLNK = 2; ! rigid affixment;
RPTR(NODE) WORLD, ! the top of the tree;
ARM, ! current ARM location;
POINTER, ! current POINTER location;
FIDUCIAL; ! Fiducial frame;
FORWARD PROCEDURE UPDATE; ! updates display;
INTEGER UPDSUPPRESS; ! if >0 then do not display;
INTEGER ALCH,ALEOF; ! channel number for AL output;
STRING ALFID;
INITIALIZE(ALCH←-1);
INTEGER PCH,PCEOF; ! channel number for pointy commands;
STRING PCFID;
INITIALIZE(PCH←-1);
DEFINE DEG = "(π/180.0)";
DEFINE ALT = '175; ! **** The losing Stanford ALTMODE ****;
REAL TINY; INITIALIZE(TINY←0.01);
REQUIRE 600 SYSTEM_PDL;
! Macros to communicate with Handy and invoke Wave functions;
IFCR YVERS THENC
SMP TO_ARM(REAL ARRAY T;REFERENCE INTEGER FLAG);
INTEGER ARMFLAG;
DEFINE α(S) "[]" = [ISSUE(7,"NODES","HANDY",MESSAGE S)];
! MACROS TO START, END, AND DO TRAJECTORI DEFINE βSTART "[]" = [α(START_TRAJECTORY("TEMP",0))];
DEFINE βEND "[]" = [α(CLOSE_TRAJECTORY)];
DEFINE βDO "[]" = [α(DO_IT(0,"TEMP"))];
DEFINE βBLOCK(S) "[]" = [BEGIN
S
END];
DEFINE βEXEC(S) "[]" = [βBLOCK(βSTART;
S;
βEND;
βDO)];
! MACROS TO MIMIC WAVE;
DEFINE βMERGE "[]" = [α(MERGE_ARM)];
DEFINE βMOVE(S) "[]" = [α(TO_ARM(S,ARMFLAG))];
DEFINE βHERE(S) "[]" = [βBLOCK(α(ARM_POSITION(NULL));
ARRBLT(S,ARM_LINK[6,1,1],16))];
DEFINE βCHANGE(V,D,T)
"[]" = [βBLOCK(α(CHANGE_ARM(V,D,V,0,T,ARMFLAG)))];
DEFINE βFREE "[]" = [ARRBLT(FREE_ARM[0,1],LIMP_ARM[0,1],42);
βMERGE;
βCHANGE(DOWN,0,3000)];
! INITIALIZATION PROCEDURE: TELLS UPPER SEGMENT "I AM NODES" AND WAITS
FOR HANDY TO GET STARTED;
PROCEDURE STARTUP;
BEGIN
OUTSTR(CRLF&"NODES");
PUT_DATA(0,0,"NODES");
WHILE ¬YES_HAND DO CALL(1,"SLEEP");
OUTSTR(" EXECUTION STARTS ..."&CRLF);
END;
REQUIRE STARTUP INITIALIZATION;
! INITIAL VALUE FOR ARRAYS;
PRELOAD_WITH 6,0,0,0,0,0,
1,0,0,0,0,0,
0,1,0,0,0,0,
0,0,1,0,0,0,
0,0,0,1,0,0,
0,0,0,0,1,0,
0,0,0,0,0,1;
REAL ARRAY LIMP_ARM[0:6,1:6];
PRELOAD_WITH 0,0,-1,1; REAL ARRAY DOWN[1:4];
ENDC
! P@I←GKIUeKfAQ↑AQC9IYJA YkJA¬eZv~(~∃∪
$A¬-∃%&A)! ≥ε~(~∃% E+∪%
E)→↔∃ k7!9(Y%⊃Q:DA→=βλ1≠= +→
l~∀~∃∃1) ¬9β_A∪9) ∂ HA!%∨
+%∀A) ↔∃ jQ%∃β_AβI%β2AQ≥&Yβ9∂→ &$v~∀∩∧AMSY1fA)≥LAoSi AieC9ga←g∀PyCe4AieC9f|RX↓β≥∂→∃&AoSQP~∀∩AU←S9hAC]≥YKf@!β≥∂→∃'6o:uQC]H$AS\A⊃KOeK∃f@LA%]GQKL\~∀∩A%KiUe]f@@ASLA¬YXA←,XA←i!KeoSMJAeKQke]fb\~∀$v~∀~)!%∨π∃ +%
↓% βλa¬→+
!% β_↓β%%βdAαRv4∀∪¬ ≥∪≤~∀%∪≥) ≥ $A∩1∀v~∀%∨/≤AI β_A¬%%β2↓¬ ')9'6btPXbtitXA¬ Mβ≥∂→∃'6bt]:v~∀%∪ A)1↔ j!¬ ')9&Y¬ Mβ≥∂→∃&RA)! ≤@~(∩∪β¬=%(PE∃%%∨$↓∪≤A%∃β ∪≥≤Aβ%~λRv~∀%β%%π1$QαRl~∀∪
=$A∪>DA') @@bA+9)∪_@LA ≡~(∩@@@↓
∨$A)>bA'Q @b↓+≥)∪0@hA <~∀∩∪¬7∩Y∃u?¬ 'Q≥'7∀1∪:v~(∪β6h0i;>b8`v~∀% ≥λv4∀~∃ 9 ε~∀_BAGUeg←dLACe%iQ[KQSFAgQCGVA⊃KMS]%iS←\l~∀~∃Iπ→β'LA')β
⊗Q')I∪≥∞A%λw∪≥Q ∂ $↓! YQ∨ Y%∃∂∪')∃$w%β92Aβ%Iβ2Aα$v~∀∩∧A∪λA%fAgS5aYrAQQJAaIS]hA9C[JA=LAiQ∀AgiC
V\~∀$@Agi¬GVA[¬]COK5K]hAMkEe←UiS]KL\A! @ASfAQQJAS9IKpA=LAiQ∀~∀∩@↓i←`A∃YK[K9hAS\↓α\Aβl`u)∨A:ASf↓CeeCdAkgK⊂Ai↑~(∩@AQ=YHAi!JAgi¬GV\@↓% ∂∪M) $A%fAiQ∀Aβ I '&A=LABAYCeSC YJ~∀$@AoQ%GPAC1oCsf↓Q←YILAiQJ↓i←`A∃YK[K9hA←L↓iQJAMiCGV8~∀∩v4∀~∃!I∨π U%
A≠¬↔ '),Q')%%≥∞A∪⊂w∪≥)∃∂ $AQ∨ w%∃
% 9π
A%¬≥2A%∃∂∪')∃$Y')-∪λRv4∀∪¬ ≥∪≤~∀%%β≥2↓β%%βdAβ6`i)∨!:l~∀∪'Q↔∪ ?9 .1%∃π∨%λ!')βπ,Rv~∀%')βπ,u∪ 7M)↔∪ u?∪λv4∀∪')¬π⊗u!⊃!7')-∪ ;>4bv~∀%% ∂∪M) %?9+→_1I π∨%⊂v~∀∪M)βπ⊗i)∨!7M)↔∪ u?)∨ l~∀∪'Qβπ⊗uI ∂∪'Q %7'Q↔∪ ;⎇→∨πβQ∪∨≤QI ∂∪'Q $Rv4∀∪≠ 5∨%371∨πβ)%∨≤Q'Qβπ⊗u¬7')↔% :S:]≠ ≠∨I37→∨
β)∪∨8QαS:l~∀∪ 9λv~∀4∃
%≥
A
→')⊗!∪λY↔%≥λY)= Y!≥%λY'∪⊂R@E7tD@z@4∀∪6A¬''∪∂9εA'∪⊂@z@D⊂DMπ-A&Q∪λ$v~∀∩A%!)HQ')β
⊗RA'%λv~∀$@A%!Q$Q↔∪9λRA∪⊂v~∀∩A∪≥∪Q∪β→∪i
Q≠β- ')⊗!!≥∪λ1)∨ Y%λY'∪⊂RS:v4∀~∀B↓Gkeg=dAgi¬GWfv4∃ π→M)⊗QπU%≥∨ ∀Y≥∨ ∀XhXE8tDRv$BAOK9KeCX↓o←eW%]NAe∃OSgi∃dv~∃⊃π→'),Qπ+%⊃βλY≥=
Xh0EλtD$v∩BA]QKeJ↓gkEa¬eifA¬eJAi<AEJA¬MMSq∃Hv~∃⊃π→'),Qπ+%Aβ)⊂Y9∨
XPXE tλRv∩B↓Gkee∃]hA]¬[JAe∃G←O]%iS←\↓gkEiIKJv~) π→'Q⊗Qπ+I% Y9∨
XPXE$tλRv∩B↓Gkee∃]hAe∃MKeK9GJAMIC[JA→←dA[=iS←\l~∃ π1')⊗Q
+%≠∨Y
Y≥∨⊃
XhX ~tDRl∩BAGUeeK]PA[←i%←\AMIC[Jv4∃ π→M)⊗QπU%)% ∀Y≥∨ ∀XhXEPtDRv$BAGkIeK]h↓ECgJ↓]←IJ↓M←dA⊃SgaY¬rA←L↓ieKJl~∃ π1')⊗Q
+%↔∪1_Y≥∨⊃
XhX ⊗tDRl∩BA[¬OSGC0AWSY0AgiC
Vv~∃⊃
∪≥∀Aπ+%M∨%&@ 7:D{lIπ+%9∨
X⊃π+% ¬λXIπU%!β) XIπ+I% X⊃π+%≠=-
XI
+%↔∪1_XIπU%)% ∃:v~∀4∃%!)HQ')β
⊗RA→¬')π+I'∨$v$∩BAY¬ghAGUeg←d↓←aKe¬iKHA=\v~∀4∃
%≥∃α⎇α:⊃↓∃Zu ↓hαnb~,bQ2Z,~R>Ie~∞ε2
∩ul4Ph)¬β∂∪'S#n+S'
π≠Sπ∂←→l4*$~2NRZBεNR ~-">∧r⊃1Eβ↓1
¬R⊃%l%
β?C↔⊗ ;⊃β∨#π∂-Xh*∩∞e~R-"∃~Rε∞Zb>B:"aEAAb∩ i KX%¬β␈β↔Kπv!βOS∞≠-l4T"∞2N$Y">N$
∞-2⎇α:⊃1 ↓A1
{Q %lJ ↓ ?␈βM β∨#π∂-Xh*∩⊗4J:*λ~$M$
4α∃]T$βj¬4∧D
≥H_4ZbH*5$ 95B$⎇:H∀≤Z W0hPQ*%¬%%
5$ 95∩∧d~:D
∀~IβXH∀∀εf∂>@ε∂⊗≡Mεn/M≤2π∨L≤6Zε} W⊗∂L\Bε}g1PPh**¬%∩
:D ≤5∀∧d
8J5$ 970HJ∀
F∂∨D∞7&∞=4ε␈ε↑,↔&.D
vsXQ!PT4z*t
∀D
4Lm HR¬≥J)∀t:
$|≤XJU∀(⊂uH{
∀Q(→λ⊗
'1"QSj*p4Q∧
u∀R)hh∀∀Ixq1∃*(αP'h∪")j)
)(*)
'h'"
P'h_J]FEεBβ⊂P9z_quP7\2y0z~ww9]CEεE)∀*)∀ S,L!f⊂iiTP∀)'abQ*i"P∀j aeU'h∀)∀*)∀)U aeTH)j%TNFE∧dQ⊂)j Pe]("∀-ij%W↑_⊂*∩"gεEαDi"j∃i'∀'∃f& )⊃agi"
FE∧bS)bFEαDi"j∃i'∀)U ae]⊂mij%Wmij Pe]("∀-ij%WnT]FBεE)(∃)∀ g⊗L!f TiTP(∀'abb∃i"P(∃id)j∩T)(*∀∀)j PeTP)U%]i(∃)∀ g⊗L!f TiTP+⊂f∀]FB∧a"cRgεE∧Tj aeN("(-Tj%noTj aeN("(-Tj%nUL]FE∧Rc⊂)j⊂ae](⊃(-ij∩n←)j⊂ae]*∪h-ij∩nP*$⊃gεE∧Ba"cdSεE∧DRg*"cQi⊂$]CE∧DPH*42P≤z0quH4yP1≠7pz2Y⊗⊂29≠x⊂17]:7vP→v2vr[:↔εEαDP⊂∀λ∃∃∃⊂⊂i)!&∃⊂;wz[2⊂;w\5P30\z2y⊗λ1:z⊂≥44yP~yP2p\try⊂≥7P92Xr⊂∃∃
∀FE∧B]FE∧Bc'i⊂∩oXP)U"h⊂_H*g*$S⊂)j Pe]*'T-ij%WP"'FB∧DDiU ae]⊂mij%WmdVXWoij Pe] mTj%nmRn]FEαDij Pe]("∀-ij%Woij Pe]*'T-ij%W]FE∧Bbg"≥CE∧ij⊂ae] Vij%nVij aR]("(⊗ij%nWok f∞FE∧fQfgi,Vij aR])"cRij"i⊗ij%nWofbfSi,mf∪a`j$Sg∀+ S∀n]FB∧f iU)j aRoij%NFE∧i⊃j*i'
+ f∀NFE∧bS"≥FEβE)(*∀∀ g,F!f iTTP()∪abb*T"P('T)j%T∀(*)∀∀j aeJP)j%J]FE∧P"cdgβE∧f Tj)j Peoij∩]FE∧Rc⊂)j⊂ae](⊃(-ij∩n↑_⊂∃$"g⊂βE∧Di⊃j*i'
'*f&ε)"agT"∀FEαbf)bCE∧Da⊃cdgεB∧Ddcλ∀)j PP[STK]←STACK:PDP[STK]-1)≥0 THEN
MEMORY[STACK:REGISTER[STK]]←
MEMORY[LOCATION(STACK:A[STK][STACK:PDP[STK]])]
ELSE
MEMORY[STACK:REGISTER[STK]]←0; ! same as null_record;
RETURN(STACK:A[STK][STACK:PDP[STK]+1]);
END;
END;
PROCEDURE EXCHSTK(RPTR(STACK) STK);
BEGIN
RPTR(ANY_CLASS) E1,E2;
IF STACK:PDP[STK]<1 THEN RETURN;
E1←POPSTK(STK);
E2←POPSTK(STK);
PUSHSTK(STK,E1);
PUSHSTK(STK,E2);
END;
RPTR(ANY_CLASS) PROCEDURE ROLLUPSTK(RPTR(STACK) STK);
BEGIN
INTEGER I;
RPTR(ANY_CLASS) V;
IF STACK:PDP[STK]>0 THEN
BEGIN
V←POPSTK(STK);
STACK:PDP[STK]←STACK:PDP[STK]+1;
FOR I←STACK:PDP[STK] STEP -1 UNTIL 1 DO
STACK:A[STK][I]←STACK:A[STK][I-1];
STACK:A[STK][0]←V;
END;
RETURN(STACKTOP(STK));
END;
RPTR(ANY_CLASS) PROCEDURE ROLLDOWNSTK(RPTR(STACK) STK);
BEGIN
INTEGER I;
RPTR(ANY_CLASS) V;
IF STACK:PDP[STK]>0 THEN
BEGIN
V←STACK:A[STK][0];
STACK:PDP[STK]←STACK:PDP[STK]-1;
FOR I←0 STEP 1 UNTIL STACK:PDP[STK] DO
STACK:A[STK][I]←STACK:A[STK][I+1];
PUSHSTK(STK,V);
END;
RETURN(STACKTOP(STK));
END;
RPTR(ANY_CLASS) PROCEDURE ITHELT(INTEGER I;RPTR(STACK) STK);
BEGIN
INTEGER J;
J←STACK:PDP[STK]-I;
IF J<0 THEN
ABORT("STACK INDEX OUT OF RANGE");
RETURN(STACK:A[STK][J]);
END;
! symbol table routines;
RCLASS SMBL(STRING KEY;RPTR(RLIST) HITS;RANY NXT);
DEFINE HTMSK = "'377";
RPTR(RLIST) ARRAY SMBTBL[0:HTMSK];
SIMPLE PROCEDURE INITBL;
BEGIN
INTEGER I;
FOR I←0 STEP 1 UNTIL HTMSK DO
SMBTBL[I]←NEW_RECORD(RLIST);
END;
REQUIRE INITBL INIT@∪β1∪5β)%∨≤A6A:v~∀4∃'∪≠A→
A∪9) ∂ HA!%∨
+%∀A⊃β' flQ'Q%∪≥∞↓&Rv~(∪¬ ∂%≤~∀∩∧AeKiUe]fA∧@fl[ ShAQ¬gQKH↓mCYk∀A←LAL\A≠KQQ←HAM←[Ko!ChAM=YY←oL~∀∩@↓↔]ki XAGP8@l\h0AoSi AG←]MiC]h↓gi←Y∃\AMe=ZA≠∃ \~∀∩l~∀∪ ∃
∪≥
↓π≥'(z@DNTbfjd\hjdbTnDv~(∪∪≥)∃∂ $A Y_v~(∪→?→∃≥∂)⊂!&Rw⊃|`v~∀%/⊃∪→∀A)%+∀A ≡~(∩∪¬ ≥∪≤4PH&!αz↓"!αDzIα∞5~&a"~I%l4PH$&N$
JPb≤z∩∃↓
βCWS~β#'∨Bβ?K∪/⊃β∪'>KSMβ}1α!*≤rNQβNsS=αCX4($HJ6>Z*↓E2!Xh($$LjV1↓
bn∞:≥"ul4PH$&6⎇2⊗5↓
b!l4PH$&⊗t!l4(HJ2}1k1l4(HJ&→αcqAαRD*84(HH&N}≥Y]αRz:t4PH&⊗2≤(4($HJJ⊗R-∩9"!KX4($L*:⊃lhP&⊗:#X4(4U∩BRIE~6
1JαN6 Z↓¬β≠␈⊃βWO*β eβ∨K7 ?bβSπ f)βK?/#';↔~β?;3KX4*&u"⊗≡⊗∩αN6
Lral4Ph*
>|b⊗ε9¬αJ>∞,"VJ∃¬~6
N≤A"NR∀J:≥α\*e%lhP&
⊗<J84(Lz↑9α∃αRI"≤*21¬∧~
l4PJN6
Lrb}"
~!MYDZ⊗e%∧bε:⊃∧BR6N[X4(&≤~}J2M~Qj~M∩NRn≤j
R
eZN6
LrbvuXh(&↑DJ2∃α≤_n:Vd`bJ⊗≤zJ⊃α$x4($L∩⊗≡&ph($&≤j
}2dzA"∞~Il4(HJ&→α-
U"Nl∩1j.-JnN6∃i2.⊗JIαR",p4($HJ
⊗≡Lp4($HJ∞∞}u*20b∀*∞>J#X4($HJJ⊗R-∩9"R∃*∃%lhP$$&,r⊃l4PH&⊗:#X4(&∀*RVJrB~ε2≤)%l4PJ⊗:⊃Xh(4*¬∩>∞⊗%*J∃α,rNf5E~RJ&t9α.⊗KZJε:JαZε1KX4(&∀*≡&8hP&&→*N6
≤~!".-I%αRD*84(HJ
⊗≡Lp4($M~6
}t*\bJ,~>J⊃E~6
1KX4($M~6
1TZ⊗fn≤j
v}\*el4PH&N6∀aj"&%~nN6∃j}:⊗9BJ⊗∞⎇∩⊃"JdJNQ%Xh($&∀bε∩⊃E~6
R∀bnN6∀J:bue~6 1αIl4(HJ⊗:⊃Xh(&&2αJ2&uA"N6∀aj"&%~nN6∃i2ZεbIuAα$B⊗84PH&J2 "⊃"Nl∩1j"M"NnNl∩u2Z a1A%Xh(&⊗t!l4(hRBJ>≤*∩VJ*α∩⊗2≥J5"N%∩&:≥∧Z⊗en∀
:eα4
1%lhP&
⊗<J84(LJ→αNl∩N∞!DZ⊗e%¬""⊗8hP$&
,:&8$hP$&Je∩⊗5"≤j
1jDJRNn≤j
u24
11eKI%l4PH&&→¬∩2&N#R2⊗:]~6
1TB&RN]~6
vkj:V2aBJ⊗∞⎇∩⊃αRD*84(HH&J2∀*5"Nl∩R
2]~6
&uBu2Nl⊃1E%Xh($&,r⊃l4PJ⊗:⊃Xh(4(1¬β∞∪?KQXh(4*M"⊗6Z
⊃α⊗N≤
B∃mα β#?f#Mβ¬πβK?∂.#WK∃εKS↔5π#=β *βπCCfK↔⊃β↔Iαε
⎇∩Ql4U∩⊗FVM∩∃↓Eαα:⊗\DJR⊗6≠X4(4T*bR⊗∀rε1α¬∩>∞⊗%*J∃α∀
&1lhR
>>d*ε9α∀
&RJβY↓¬βN1βO↔"aβS#.qα
εLaβ←'faβ ∃ε≠π33.!β e∧
>J#X4(4UαJ>∞,"VJ∃∧
>J"BNRJLr≥αMB∩?9β6{WKSBβ∪?←raβ/'≡Y¬ %KX4(&∀*≡&8hP%¬α&C'MβO→βS#*β?;3JβK↔πfce↓ >KkπK&ce β7+;∂SN{9βW≡+⊂4(J↓β'9π##↔O*βK?W&K;↔Mr↓α↔O≡+;S'∞c3e1εKQβC⊗K;SMπ##∀4PI↓β↔↔∪?Iβn+OOπ>)1βπv!βS#.qβ∂πfcM↓#6K¬αε¬α2e%π##∀4PI↓β≠.s∂S'}qβ'9∧*N∞ε∧)9↓α'KC'∂∞c3e1π##'Mε3W;∂&K?84PI↓β←Nc1β *βO?7/##';:βS#π"βSπ//→βg?*β π∂ZβS=β
βS?Ah(%↓εc↔[↔bp4(4PI↓α'2α
ε&%∩Aβ'~βO↔QbβS#↔rα
ε&bβ←'3bβ ∃β≡ 33↔"β ↔≠␈∪∀4(J↓βS#*β∂π3bβS=α-~∞εB*p4(%Xh(4(LzVRN%⊃! ↓RQ)↓ 5→→ ↓RQ)↓ 4~J2→KX4(&L1α
εM"JAα$B⊗9α∀
&1lhP&&→∧*N∞ε∧)vε:JαR"⊗ph($&-~⊗J⊗∃⊃!E1
a α⊗≤~εB∃¬*:&RL
2&j,!9↓α ∩>JQ∧JMα∞|r~VN,!↓ $hP&⊗2≤)4(HJεBBeI ="-~∞εB*I%l4PJ⊗:⊃Xh(4(1¬βv+\c;}#∃1β.s3;,Fs?β∃bβ'Lc∞s∂/>Mw∩b
MfYFm|F*b =wπI∞N&.*D 6}wN-vff\Cε↔K1Q hU*
E∩DixD*J
$|≤XJU∀
hU9DixD*E:J$Ltt
∧rK1Q L∀Xy∀ph!~$, Dλ∃∃∀≠∀∧
[↔&Rc &KSXh!~%¬%% d|$U∀∧t#1Q LtKyd-9
(T≤⎇(E∧t|HU∪Xh!→d|$W*∧t X[4t%[z∧sXQ!∀
[∃F∃m|≠6"c∃[x∃[~F;U|
6EC%mv∃cβXQ!∀l,Yz%M\Ix4
$→ybD
≠Rtl,Yz%M\Ix4
$→ybDtxHSUDk9d%j≠W0hP_Ye≥LU
∧rdhE∪Xh!~$-%Z)bDtE↔0hP_Yd#XQ!PU¬)x4,%Z(R¬,iIdYDixD*E*
E∩DixD*J e∪Xh!_$,<→aPPJ∀ '⊗.≥>2ε?,≡εBεM≥f←~ mw∩εm|F*∧g1PPM*
E∩DixD*J ∃D+XQ!∀-|ixD+TX*$⎇\kW0hP→_bαE≠yd|$W+∀∃∀{9ejKYjTda
(T≤⎇(D¬$DYaPPH_(T<LaQ HL_d∧t|HW$$ K9ei\jYDaE(X4⎇∀D
DD,aQ HH→it$+*9tu\ixD+TH_E\u[[t+XQ!⊂L,hAPPLYJ4(h!⊃∀t|HW$,∃){5MmxW0hP→_b∧)9jTda
(T≤⎇(D¬$DYdhP⊃→d|$W+∀∃∀{8Um⎇↔1PPLixD+TX*$⎇\k[tu,IC¬∀,9z$#XQ!∀t|HW%L∃){4umyjTda
(T≤⎇(G0hP→it$+(H∀%\k[tu,IC¬∀,9z$#XQ!∀,tG1PPh()t|dX→b¬¬)x4,%Z(R∧M3λ∀t≤Z:D⎇∩
*¬%∩ it$*∀ bd"↔1PPL(XtLpQ!∃<D→HR∧q9jTda
(T≤⎇(D∧$xQ!⊂LLd cl"
I∧,r↓Q HH~(U%-)e¬%∃XU⊂hP⊃_Te≤QQ HH→ktt|HW$$ K9ekXQ!∃∀-JZ$rDh→E≤*↔1PPLYhCXh!Q%¬∀x8T%-(T∧dt3 d|$U
%¬%% d|$U∀∧rdE↔0hP_(T<LaQ J
∞<W'~∞↑απε⎇≥g&/$∞7'↔\>G/⊗T f␈∩ dπ&z ,Rε
=εNfD
v2∧G1PPL_d∧M→λ→d≤-:Iu∩DEIbJ¬IλTph!⊃∀ ∀z*BB∩λ(∀≤]x~$%~λ_d4M XTu"%↔0hP→_b∧txHST$_K4ui9jTda
(T≤⎇(D¬$DYaPPH~Yddt3 d|$U bKXQ!∀L2¬ d|$W(T∃∀{9em|ixD+U9ye\%U∪4u,IC¬∀,9z$"¬IλTph!⊃∀t|HW%L∃){4t|HW$,∃){4um[ycXh!→d|$W+∀∃∀{9em|jYDaE(X4⎇∀G1PPLixD+TH_E\u[xCXh!→d|$W*4|u8KU|s1Q L,hG0hPQ*%¬%% d|$U∀¬∀,:Z%≤MhT¬¬∀x8T%-(T∧≤⎇ ∪¬%∀XU¬∃¬J%∧t|HU∩∧tE↔0hP_(T<LaQ J
=wεN↑4π&FT∞7'↔\>G/⊗T∞&}␈L\Bε∂D d"r∧ F.∂l↑2ε≡}∂∩αDihBHh!∀αε∞lm↔F.D∞Fz∧H_E\tKW0hPQ!∃∃¬J%∧t|HU∩∧thG0hP~*¬%∩ it$*∀ 4L%71PPLihE|tZs∧t|HU∧t|HW%∧t→XU\tKU∪Xh!⊃∩
π<↑G~π=⎇bbε.-w&F↑.2bεL≤Bπ&ull_record;
ARRTRAN(NODE:XF[NND],NODE:XF[ND]);
NODE:HOWLINKED[NND]←NODE:HOWLINKED[ND];
KIDS←NODE:SON[ND];
WHILE KIDS≠NULL_RECORD DO
BEGIN
LNK_NODE(COPY_TREE(KIDS),NND);
KIDS←NODE:EBRO[KIDS];
END;
LNK_NODE(NND,WORLD);
RETURN(NND);
END;
BOOLEAN PROCEDURE CONTROLLED_BY(RPTR(NODE) N,D);
BEGIN
! **** The Mikado syndrome strikes again. I know how to
do this but am too lazy to code it up;
RETURN(TRUE);
END;
! purge_id, fix_id;
RECURSIVE PROCEDURE PURGE_ID(RPTR(NODE) ND);
BEGIN
! removes all nodes in the subtree rooted at ND
from the symbol table;
DELSYM(NODE:PNAME[ND],ND);
ND←NODE:SON[ND];
WHILE ND≠NULL_RECORD DO
BEGIN
PURGE_ID(ND);
ND←NODE:EBRO[ND];
END;
END;
RECURSIVE PROCEDURE FIX_ID(RPTR(NODE) ND);
BEGIN
! adds all nodes in the subtree rooted at ND
to the symbol table;
DELSYM(NODE:PNAME[ND],ND);
ND←NODE:SON[ND];
WHILE ND≠NULL_RECORD DO
BEGIN
FIX_ID(ND);
ND←NODE:EBRO[ND];
END;
END;
! some arithmetic on transform matrices;
! Eventually, may want to make these cleverer;
PROCEDURE XFXFMUL(REAL ARRAY A,B,C);
BEGIN
! C ← A*B;
INTEGER I,J,K;
ARRCLR(C);
FOR I←1 STEP 1 UNTIL 3 DO
FOR J←1 STEP 1 UNTIL 4 DO
BEGIN
FOR K←1 STEP 1 UNTIL 4 DO C[I,J]←C[I,J]+A[I,K]*B[K,J];
END;
C[4,4]←1.0;
C[5,4]←0; ! angles are not valid;
END;
PROCEDURE XFINVRT(REAL ARRAY A,B);
BEGIN
! B ← inv(A);
INTEGER I,J;
ARRCLR(B);
FOR I←1 STEP 1 UNTIL 3 DO
FOR J ← 1 STEP 1 UNTIL 3 DO
BEGIN
B[I,J]←A[J,I];
B[I,4]←B[I,4]-B[I,J]*A[J,4];
END;
B[4,4]←1.0;
B[5,4]←0;
END;
PROCEDURE INVXFXF(REAL ARRAY A,B,C);
BEGIN
! C ← inv(A)*B;
OWN REAL ARRAY XFTMP[1:5,1:4];
XFINVRT(A,XFTMP);
XFXFMUL(XFTMP,B,C);
END;
PROCEDURE IABAMUL(REAL ARRAY A,B,C);
BEGIN
! C ← inv(A)*B*A ;
OWN REAL ARRAY XFTMP[1:5,1:4];
INVXFXF(A,B,XFTMP);
XFXFMUL(XFTMP,A,C);
END;
PROCEDURE ABIAMUL(REAL ARRAY A,B,C);
BEGIN
! C ← A*B*inv(A) ;
OWN REAL ARRAY AITMP,TMP[1:5,1:4];
XFINVRT(A,AITMP);
XFXFMUL(B,AITMP,TMP);
XFXFMUL(A,TMP,C);
END;
PROCEDURE SET_ROTATION(REAL ARRAY XF;REAL W,PH,TH);
BEGIN
! fills in the rotation part of XF to correspond to
ROT(Z,TH)*ROT(Y,PH)*ROT(Z,W)
;
REAL SW,CW,SPH,CPH,ST,CT;
SW←SIND(W);CW←COSD(W);
SPH←SIND(PH);CPH←COSD(PH);
ST←SIND(TH);CT←COSD(TH);
XF[1,1]←CW*CPH*CT-SW*ST;XF[1,2]←-CW*ST-SW*CPH*CT;XF[1,3]←SPH*CT;
XF[2,1]←CW*CPH*ST+SW*CT;XF[2,2]←CW*CT-SW*CPH*ST;XF[2,3]←SPH*ST;
XF[3,1]←-CW*SPH;XF[3,2]←SW*SPH;XF[3,3]←CPH;
XF[5,1]←W;XF[5,2]←PH;XF[5,3]←TH;
XF[5,4]←1.0;
END;
PROCEDURE DECODE_ROTATION(REAL ARRAY XF;REFERENCE REAL W,PH,TH);
BEGIN
IF XF[5,4]>0 THEN
BEGIN
W←XF[5,1];PH←XF[5,2];TH←XF[5,3];
END
ELSE
BEGIN
REAL SPH;
PH←ACOS(XF[3,3]);
SPH←SIND(PH);
IF ABS(SPH)<TINY THEN
BEGIN
PH←IF XF[3,3]>0 THEN 0 ELSE π;
TH←0;
W←ATAN2(XF[2,1],XF[2,2]);
SET_ROTATION(XF,W,PH,TH);
END
ELSE
BEGIN
W←ATAN2(XF[3,2],-XF[3,1]);
TH←ATAN2(XF[2,3],XF[1,3]);
XF[5,1]←W;XF[5,2]←PH;XF[5,3]←TH;
XF[5,4]←1.0;
END;
END;
W←W/DEG; PH←PH/DEG; TH←TH/DEG;
END;
! arithmetic ops: tr,apush,apop,atop,tmul,tinv,tedit,oops;
PROCEDURE OPNDCHK(RPTR(OPND) OP;INTEGER OPK);
IF RECTYPE(OP)≠OPK THEN
ABORT(" WRONG OPERAND TYPE");
RPTR(XFELT) PROCEDURE NEW_XFELT;
BEGIN
REAL ARRAY XF[1:5,1:4];
RPTR(XFELT) X;
INTEGER I;
FOR I←1 STEP 1 UNTIL 4 DO XF[I,I]←1.0;
XF[5,4]←1.0;
X←NEW_RECORD(XFELT);
MEMORY[LOCATION(XFELT:XF[X])]↔MEMORY[LOCATION(XF)];
RETURN(X);
END;
RPTR(XFELT) PROCEDURE TR(REAL W,PH,TH,X,Y,Z);
BEGIN
RPTR(XFELT) XFE;
XFE←NEW_XFELT;
SET_ROTATION(XFELT:XF[XFE],W,PH,TH);
XFELT:XF[XFE][1,4]←X;
XFELT:XF[XFE][2,4]←Y;
XFELT:XF[XFE][3,4]←Z;
RETURN(XFE);
END;
RPTR(STACK) PROCEDURE NAMEDASTK(STRING S);
BEGIN
RPTR(STACK) STK;
FOR STK←ARITHS DO
IF EQU(STACK:ID[STK],S) THEN RETURN(STK);
ABORT(S&" IS NOT AN ARITHMETIC STACK");
END;
RPTR(OPND) PROCEDURE APUSH(RPTR(OPND) VAL;STRING STKID(NULL));
BEGIN
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
PUSHSTK(LASTARITH,VAL);
UPDATE;
RETURN(VAL);
END;
RPTR(OPND) PROCEDURE APOP(STRING STKID(NULL));
BEGIN
RPTR(OPND) VAL;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
VAL←POPSTK(LASTARITH);
IF LASTARITH≠$OSTACK THEN
PUSHSTK($OSTACK,VAL);
UPDATE;
RETURN(VAL);
END;
RPTR(OPND) PROCEDURE AFLUSH(STRING STKID(NULL));
BEGIN
! like APOP except doesn't save anything on OSTACK;
RPTR(OPND) VAL;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
VAL←POPSTK(LASTARITH);
UPDATE;
RETURN(VAL);
END;
RPTR(OPND) PROCEDURE ATOP(STRING STKID(NULL));
BEGIN
RPTR(OPND) VAL;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
VAL←STACKTOP(LASTARITH);
UPDATE;
RETURN(VAL);
END;
RPTR(OPND) PROCEDURE AITH(INTEGER I(0);STRING STKID(NULL));
BEGIN
RPTR(OPND) VAL;
IF LENCTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RACORD THEN
ABORT(" NO STACK INITIALIZAD");
VAL←ITHELT(I,LASTARITH);
UPDATE;
RETURN(VAL);
END;
PROCEDURE AEXCH(STRING STKID(NULL!);
BEGIN
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITAALIZED");
EXCHSTK(LASTARITH);
END;
PROCEDURE TMUL(STRING STKID(NULL));
BEGIN
RPTR(OPND) VAL,OP1,OP2;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
VAL←NEW_XFELT;
OP2←POPSTK(LASTARITH);
PUSHSTK($OSTACK,OP2);
OPNDCHK(OP2,LOCATION(XFELT));
OP1←POPSTK(LASTARITH);
PUSHSTK($OSTACK,OP1);
OPNDCHK(OP1,LOCATION(XFELT));
XFXFMUL(XFELT:XF[OP1],XFELT:XF[OP2],XFELT:XF[VAL]);
PUSHSTK(LASTARITH,VAL);
UPDATE;
END;
PROCEDURE TINV(STRING STKID(NULL));
BEGIN
RPTR(OPND) VAL,OP1;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
VAL←NEW_XFELT;
OP1←POPSTK(LASTARITH);
PUSHSTK($OSTACK,OP1);
OPNDCHK(OP1,LOCATION(XFELT));
XFINVRT(XFELT:XF[OP1],XFELT:XF[VAL]);
PUSHSTK(LASTARITH,VAL);
UPDATE;
END;
PROCEDURE TEDIT(STRING STKID(NULL));
BEGIN
RPTR(OPND) OP1;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
OP1←POPSTK(LASTARITH);
UPDATE;
SETFORMAT(0,7);
LODED("APUSH("&OPNDSTR(OP1)&","""&STACK:ID[LASTARITH]&""");"&CR);
SETFORMAT(0,3);
END;
PROCEDURE OOPS(STRING STKID(NULL));
BEGIN
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
PUSHSTK(LASTARITH,POPSTK($OSTACK));
UPDATE;
END;
RPTR(OPND) PROCEDURE AROLLUP(STRING STKID(NULL));
BEGIN
RPTR(OPND) VAL;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
VAL←ROLLUPSTK(LASTARITH);
UPDATE;
RETURN(VAL);
END;
RPTR(OPND) PROCEDURE AROLLDOWN(STRING STKID(NULL));
BEGIN
RPTR(OPND) VAL;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
VAL←ROLLDOWNSTK(LASTARITH);
UPDATE;
RETURN(VAL);
END;
! some arithmetic on vectors;
RPTR(VECTOR) PROCEDURE NEW_VECTOR(REAL X,Y,Z);
BEGIN
RPTR(VECTOR) V;
V←NEW_RECORD(VECTOR);
VECTOR:X[V]←X;
VECTOR:Y[V]←Y;
VECTOR:Z[V]←Z;
RETURN(V);
END;
RPTR(VECTOR) PROCEDURE VE(REAL X,Y,Z);
RETURN(NEW_VECTOR(X,Y,Z));
RPTR(SCALAR) PROCEDURE SC(REAL VAL);
BEGIN
RPTR(SCALAR) S;
S←NEW_RECORD(SCALAR);
SCALAR:VAL[S]←VAL;
RETURN(S);
END;
REAL PROCEDURE VMAGN(RPTR(VECTOR) V);
RETURN(SQRT(VECTOR:X[V]↑2+VECTOR:Y[V]↑2+VECTOR:Z[V]↑2));
PROCEDURE VM(STRING STKID(NULL));
BEGIN
UPDSUPPRESS←UPDSUPPRESS+1;
IF RECTYPE(ATOP(STKID))≠LOC(VECTOR) THEN
ABORT("NOT A VECTOR");
APUSH(SC(VMAGN(APOP(STKID))),STKID);
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
REAL PROCEDURE VDOT(RPTR(VECTOR) V1,V2);
RETURN(VECTOR:X[V1]*VECTOR:X[V2]
+VECTOR:Y[V1]*VECTOR:Y[V2]
+VECTOR:Z[V1]*VECTOR:Z[V2]);
PROCEDURE VD(STRING STKID(NULL));
BEGIN
RPTR(OPND) V2;
UPDSUPPRESS←UPDSUPPRESS+1;
V2←APOP(STKID);
IF RECTYPE(V2)≠LOC(VECTOR) OR RECTYPE(ATOP(STKID))≠LOC(VECTOR) THEN
BEGIN
APUSH(V2,STKID);
ABORT("ARGUMENT NOT VECTOR");
END;
APUSH(SC(VDOT(APOP(STKID),V2)),STKID);
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
RPTR(VECTOR) PROCEDURE VSUB(RPTR(VECTOR) V1,V2);
RETURN(NEW_VECTOR(VECTOR:X[V1]-VECTOR:X[V2],
VECTOR:Y[V1]-VECTOR:Y[V2],
VECTOR:Z[V1]-VECTOR:Z[V2]));
PROCEDURE VS(STRING STKID(NULL));
BEGIN
RPTR(OPND) V2;
UPDSUPPRESS←UPDSUPPRESS+1;
V2←APOP(STKID);
IF RECTYPE(V2)≠LOC(VECTOR) OR RECTYPE(ATOP(STKID))≠LOC(VECTOR) THEN
BEGIN
APUSH(V2,STKID);
ABORT("ARGUMENT NOT VECTOR");
END;
APUSH(VSUB(APOP(STKID),V2),STKID);
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
RPTR(VECTOR) PROCEDURE VADD(RPTR(VECTOR) V1,V2);
RETURN(NEW_VECTOR(VECTOR:X[V1]+VECTOR:X[V2],
VECTOR:Y[V1]+VECTOR:Y[V2],
VECTOR:Z[V1]+VECTOR:Z[V2]));
PROCEDURE VA(STRING STKID(NULL));
BEGIN
RPTR(OPND) V2;
UPDSUPPRESS←UPDSUPPRESS+1;
V2←APOP(STKID);
IF RECTYPE(V2)≠LOC(VECTOR) OR RECTYPE(ATOP(STKID))≠LOC(VECTOR) THEN
BEGIN
APUSH(V2,STKID);
ABORT("ARGUMENT NOT VECTOR");
END;
APUSH(VADD(APOP(STKID),V2),STKID);
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
RPTR(VECTOR) PROCEDURE NORM(RPTR(VECTOR) V);
BEGIN
REAL M;
M←VMAGN(V);
IF M≤TINY THEN
ABORT(" NORM(NIL) NOT WELL DEFINED ");
RETURN(NEW_VECTOR(VECTOR:X[V]/M,VECTOR:Y[V]/M,VECTOR:Z[V]/M));
END;
PROCEDURE NV(STRING STKID(NULL));
BEGIN
UPDSUPPRESS←UPDSUPPRESS+1;
IF RECTYPE(ATOP(STKID))≠LOC(VECTOR) THEN
ABORT("ARGUMENT NOT VECTOR");
APUSH(NORM(APOP(STKID)),STKID);
UPDSUPPRESS← UPDSUPPRESS-1;
UPDATE;
END;
RPTR(VECTOR) PROCEDURE VCROSS(RPTR(VECTOR) V1,V2);
RETURN(NEW_VECTOR(VECTOR:Y[V1]*VECTOR:Z[V2]-VECTOR:Z[V1]*VECTOR:Y[V2],
VECTOR:Z[V1]*VECTOR:X[V2]-VECTOR:X[V1]*VECTOR:Z[V2],
VECTOR:X[V1]*VECTOR:Y[V2]-VECTOR:Y[V1]*VECTOR:X[V2]));
PROCEDURE VC(STRING STKID(NULL));
BEGIN
RPTR(OPND) V2;
UPDSUPPRESS←UPDSUPPRESS+1;
V2←APOP(STKID);
IF RECTYPE(V2)≠LOC(VECTOR) OR RECTYPE(ATOP(STKID))≠LOC(VECTOR) THEN
BEGIN
APUSH(V2,STKID);
ABORT("ARGUMENT NOT VECTOR");
END;
APUSH(VCROSS(APOP(STKID),V2),STKID);
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
RPTR(XFELT) PROCEDURE VVVTRANS(RPTR(VECTOR) A,B,C);
BEGIN
! constructs the trans with origin at A, z-axis thru B, xz plane thru C.;
RPTR(VECTOR) BX,BY,BZ; ! basis vectors;
RPTR(XFELT) XFE;
PRELOAD_WITH [20] 0;
OWN REAL ARRAY XF[1:5,1:4];
XFE←NEW_XFELT;
BZ←NORM(VSUB(B,A));
BX←NORM(VSUB(C,A));
BY←NORM(VCROSS(BZ,BX));
BX←VCROSS(BY,BZ);
XF[1,1]←VECTOR:X[BX];XF[2,1]←VECTOR:Y[BX];XF[3,1]←VECTOR:Z[BX];
XF[1,2]←VECTOR:X[BY];XF[2,2]←VECTOR:Y[BY];XF[3,2]←VECTOR:Z[BY];
XF[1,3]←VECTOR:X[BZ];XF[2,3]←VECTOR:Y[BZ];XF[3,3]←VECTOR:Z[BZ];
XF[1,4]←VECTOR:X[A];XF[2,4]←VECTOR:Y[A];XF[3,4]←VECTOR:Z[A];
XF[4,4]←1.0;
ARRTRAN(XFELT:XF[XFE],XF);
RETURN(XFE);
END;
RPTR(VECTOR) PROCEDURE POSVECT(RPTR(XFELT) XFE);
RETURN(NEW_VECTOR(XFELT:XF[XFE][1,4],
XFELT:XF[XFE][2,4],
XFELT:XF[XFE][3,4]));
PROCEDURE PV(STRING STKID(NULL));
BEGIN
UPDSUPPRESS←UPDSUPPRESS+1;
IF RECTYPE(ATOP(STKID))≠LOC(XFELT) THEN
ABORT("ARGUMENT NOT A TRANS");
APUSH(POSVECT(APOP(STKID)),STKID);
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
! absxf, setabsxf, absxfe;
PROCEDURE ABSXF(RPTR(NODE) N;REAL ARRAY XF);
BEGIN
! sets up xf to be the location of N wrt WORLD;
ARRTRAN(XF,NODE:XF[N]); ! xf ← node:xf[n];
WHILE NODE:HOWLINKED[N]≠INDLNK DO
BEGIN
OWN REAL ARRAY XFTMP[1:5,1:4];
N←NODE:DAD[N];
IF N=NULL_RECORD THEN
BEGIN
BUG("FUNNY TREE STRUCTURE");
RETURN;
END;
XFXFMUL(NODE:XF[N],XF,XFTMP); ! xftmp ← xf[n]*xf;
ARRTRAN(XF,XFTMP); ! xf ← xftmp;
END;
END;
RPTR(XFELT) PROCEDURE ABSXFE(RPTR(NODE) ND);
BEGIN
RPTR(XFELT) XFE;
XFE←NEW_XFELT;
ABSXF(ND,XFELT:XF[XFE]);
RETURN(XFE);
END;
PROCEDURE SETABSXF(RPTR(NODE) N;REAL ARRAY XF);
BEGIN
! sets up link transforms so that ABSXF(N)=XF.
(If rigid affixments, will move parents)
;
OWN REAL ARRAY XFTMP,XFTMP2,XFTMP3[1:5,1:4];
ARRTRAN(XFTMP,XF);
WHILE NODE:HOWLINKED[N]=RGDLNK DO
BEGIN
XFINVRT(NODE:XF[N],XFTMP3);
XFXFMUL(XFTMP,XFTMP3,XFTMP2);
ARRTRAN(XFTMP,XFTMP2); ! xftmp ← xftmp*inv(xf[n]) ;
N←NODE:DAD[N];
END;
IF NODE:HOWLINKED[N]=INDLNK THEN
ARRTRAN(NODE:XF[N],XFTMP)
ELSE
BEGIN
ABSXF(NODE:DAD[N],XFTMP2);
INVXFXF(XFTMP2,XFTMP,NODE:XF[N]);
END;
END;
! afx_node;
PROCEDURE AFX_NODE(RPTR(NODE) N,D;INTEGER HOW);
BEGIN
! affixes N to D in the manner described by HOW;
! *** all this can be made more efficient. ***;
OWN REAL ARRAY XFTMP1,XFTMP2[1:5,1:4];
IF HOW = INDLNK THEN
ABSXF(N,NODE:XF[N]) ! xf[n]← absxf(N);
ELSE
BEGIN
ABSXF(D,XFTMP2);
XFINVRT(XFTMP2,XFTMP1);
ABSXF(N,XFTMP2);
XFXFMUL(XFTMP1,XFTMP2,NODE:XF[N]); ! xf[n]←inv(absxf(D))*absxf(n);
END;
LNK_NODE(N,D);
NODE:HOWLINKED[N]←HOW;
END;
! node_csr, id_decode, nodespec, λ;
INTEGER DOTBRK;
INITIALIZE(SETBREAK(DOTBRK←GETBREAK,".",NULL,"INS"));
RPTR(STACK) PROCEDURE NODE_CSR(STRING ID);
BEGIN
RPTR(STACK) CSR;
FOR CSR ← CURSORS DO
IF EQU(STACK:ID[CSR],ID) THEN RETURN(CSR);
ABORT(ID&" not a node stack");
END;
RPTR(NODE) PROCEDURE ID_DECODE(STRING ID);
BEGIN
RPTR(NODE) HANDLE,ND,GOODHIT;
RPTR(RLIST) HITLIST;
RPTR(CELD) C;
SPRING NID,PID;
INTAGER BRK;
HANDLE←CURPATH;
IF HANDLE=NULL_RECORD DHEN HANDLE←WORLD;
PID←ID&"."≠
WHILE LEJGTH(PID) DO
BEGIN "ONE_ID"
NID←SCAN(PID → =)¬%⊗1¬%⊗Rl~∀∩∪% @ '5
N∞BB:&⊃JαR"⊗p4($HJε
>∃!"&⊃2⊃α:> ∧∧4⎇YhB∩Kαc"A⊃2∩5 I4p
/Td¬BL:HITS[SH ¬:βX4($LJ→αJdJNQjd*:n"M"2&N%iuAα$B⊗8Q!⊂HL_)u∃" _B2∩ iu"∧izTt"%↔0hP⊃→∀2¬)I∃≥#)HTu\ ~DdM:KSk
I∧,pβ"B!⊃2⊂3HI⊃7tIIU∩
5∪∩*: *!QB"1)Jq#"A⊃"0Q(y3C"A⊃"0wj)∩4uπ(R4TjKr∩5 I4u↔'1"B"!_pπgb∩$j/g∃f& )⊃agi"∞FE∧DBkd$f⊃P!Mg∃f& )⊃agi"λ"'FEαP⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ!"cdS⊂⊃!d∩d$j)HεE⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ'"/f∪'h∀!J]FE∧BDP⊂⊂λ$c⊂$TL g!Qij'i
'"⊗$⊂g"&"JP*$"SεE⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂⊂"cdgβE⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂$Q⊂#ggQ$$j
S*f& ∀"agi⊃⊂*$"SεE⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂ a∪i*∀$Q∪⊃⊂ Sa$cjSjiQ∀CE∧DDBbf)bCE∧P⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂⊃ggb$∩j/g"∞FE∧DBDbg"∞FE∧DBP⊂⊂⊂⊃g"⊂⊃⊂d%d$U)Q≥FB∧DDdQ⊂#ggQ$$j≡S*f& ∀"agi⊃⊂*$"SεE∧DBD`a'T*∀$b ⊃⊂''U⊂#'jS"⊃∀FB∧DDbS)bFEαDDDd⊂g"&"Wcggb∩$j≥FB∧DDbS"≥FEαDbg"λ⊃'g"F$b⊃≥CE∧i"U*i'∀∩ g"&⊃T]FEαbg"≥CEεE)∀*)∀'∪b"TP∀)'abQ*i"P∪'b"iT"aT)U)$g#H'")h⊂T]FEαa"cdSεE∧i∀*)∀'∪b"TP∪"≥FEαdc⊂&⊃g#j$
'")h⊂T↑Y⊂↓⊂'")T!mY⊂⊃'i⊂_W↑Q≥⊃λ*$"gβE∧Dg⊃/ij Pej'h
''b"F!ii∀∪")h!JTFE∧Qf)bFB∧Dg"↔db "⊃agb"J'")h⊂T]FEαdc⊂'⊃≡g*f∪ )"aSi"⊂*∩"gεEαD`a'T*∀'"∀h!S⊃λ$iP'∃f&⊂⊃
]FE∧T"j*i∪∀'"∀NFE∧bS"≥FEβE)j)∩g#P&⊂ij∧≥Rg$j$Pf$m"J& ijα/Q'≥λ∀]FE∀(*)∀∪'b"TH()'aQb*i"H∧∀)j∀$g#P∪")h!J'*f&
T]FEαa"cdSεE∧dQ⊂'")T!↑g*S&⊂*$⊃gεE∧Bg")h⊂of iU∧εE∧Qf)bPβE∧Df⊂ij∧/S")h!NFE∧i⊃j*i'
''b"Th"aT∪")h!JT]FEαbg"≥CEβ⊂P2r~z4w3H7x9]λ6uL7≠r2V⊂_wx<L≠7r2Vλ70vrF77r2NFEεE⊂'gf"Pg⊂()∪abb*T"P!aR"aeT∀"c"i⊃g!bP∀(*)∀∪'b"TH!]ij∀$g#P⊂ji)gT$b∀]CE∧a"QdgεEαPP92]:y79H:9:rH4s⊂1]y9wyλ!P1w[9z0t[9P0P≠7r2WβE∧P⊂≠z42y≥tyrP_q7y:≤]FEεB∧dc⊂⊂↑g*f∪ )"aSi"⊂*∩"gεEαDa"cRgεE∧B`a'i∃∀!ji∀gi$b ⊃⊂77]⊂4w4]4pv4↑2r⊂Q
]FE∧Bi"j*T'∀# S)bT]CE∧DbS"εE∧Qf)bFB∧Di"U*i'∀∃)*bTNFE∧bS"≥FEβE()'Pbb*i⊃P&eL∪'b"T∀j)$g⊃P$b∀NFE∧a⊃cdgεB∧h*iR)j%T !ji'∪b"V'⊃kL''Q"T$b
T]FEαf'%L∪'b"T⊂ji''Q"V+gT&"∀]CE∧g'Q"]$'Uf$g%Qb-ajT''b"Wodg"∪'%]FB∧f iU!ji)Si/R!Ui''b⊃]FE∧Uh" j⊃]FE∧Qg"≥FBεE()∪abb*T"P!gT,L''Q"T)j∀$g#P∪")h!J⊃'≥⊃
T]FEαa"cdSεE∧i∀*)∀'∪b"TP∪"≥FEαdc⊂&⊃g#j$
'")h⊂T←_⊂∃$"gεB∧Dg"↔g'b"Th"aT∪")h!JFE∧bS)bFEαDg"/Pji''Q"]FEαdc⊂'⊃≡g*f∪ )"aSi"⊂*∩"g⊂ P'i*∀λ⊂!gh⊗P+d U∨Q∀]CE∧h*Td)j%J∩!ji∪'b"V⊂gh,L∃)"bT∪"∀T]CE∧`c⊗ ''b⊃T!ji∪'b"V∃gi&" $g"&∪%T]FB∧f iU!ji)Si/R!Ui''b⊃]FE∧Uh" j⊃]FE∧Qg"≥FBεE()∪abb*T"P' SbL''Q"T)j∀$g#P∩b∀]FBIF CCHECK(CURNODE,"N:") THEN
BEGIN
NODE:PNAME[CURNODE]←ID;
LASTCURSOR←$CURNODE;
UPDATE;
END;
END;
! editing ops: affix_node, rigid, nonrigid, independent, merge;
PROCEDURE AFFIX_NODE(INTEGER HOW);
IF CCHECK(CURNODE,"N:")∧CCHECK(CURDAD,"D:") THEN
BEGIN
AFX_NODE(CURNODE,CURDAD,HOW);
LASTCURSOR←$CURNODE;
END;
PROCEDURE RIGID;
BEGIN
AFFIX_NODE(RGDLNK);
UPDATE;
END;
PROCEDURE NONRIGID;
BEGIN
AFFIX_NODE(NRGLNK);
UPDATE;
END;
PROCEDURE INDEPENDENT;
BEGIN
AFFIX_NODE(INDLNK);
UPDATE;
END;
PROCEDURE MERGE;
IF CCHECK(CURNODE,"N:")∧CCHECK(CURDAD,"D:") THEN
BEGIN
IF CURNODE=CURDAD THEN
ABORT("INVALID MERGER");
UPDSUPPRESS←UPDSUPPRESS+1;
WHILE NODE:SON[CURNODE]≠NULL_RECORD DO
AFX_NODE(NODE:SON[CURNODE],CURDAD,
NODE:HOWLINKED[NODE:SON[CURNODE]]);
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
! editing ops: kilL, unkill;
PROCEDUR@
A↔%→_Q'Q%∪≥∞↓≥ '! PE≤tλRRv~(∪¬ ∂%≤~∀∪I!)$Q9∨
R↓λY≥λl~∀∪%A)$Q'Qβπ⊗R↓π'$v4∀∪∪ ↓→ ≥∂Q⊂Q≥ M!εR|@A)⊃ 8~∀∩∪9 ?≥∨⊃ '! Q≥ 'AεR~∀% →'
4∀∩∪≥⊃?')β
↔)∨ Iπ+%9∨
Rl~∀∪∪_A≥λ{9+→_1I π∨%⊂A)⊃ 8Aβ¬∨I(PDA-∪→1¬:"εQz⊃%l4PJ∩}:|"∃j∩ "n:∩kX4(&,r2:,Dr>∩∃Dr⊃%lhP&:>$)j∩ε%Z:∩v|!l4(MαVN"≥"-!∩≥*J.&da2:⊃KX4(&¬*J≡∀DJ⊃":"Il4(L2>Iα≥~Iα⎇∧~VJN⎇∩Mα∩xh($&∀*≡&8hP$&&2α∞NIj"∞VJ\J21α$B⊗9α≤z:R&u*∃l4PH&↑"Lb∃α&→Bε:∞-~R>IE~Rε∞]">A"≥~I%2t!%α∩xh($$Mα>BN$Y"∞N∩Il4(HJ⊗:⊃Xh(&2
~R∞V∃~>J⎇$~VJ:|"∃l4PJVB∩
"∃l4PJ⊗:⊃Xh(4*¬∩>∞⊗%*J∃α,r.&2cX4(&∀*≡&8hP&JB%⊃":>$)%α:"b∩⊃lhP&:∩⎇α>BN$Y!∩∞-∩.&2bIl4(LJ→α:!Z:V2aBJ⊗∞⎇∩⊃αRD*84(HJ
⊗≡Lp4($L"∩}:|"∃j∩ "n:∩kX4($Lr>∩∃T"ε∩nt"v}:,b0bJ,~>J⊃Xh($&4J`b&"B:⊃%Xh($&dr,b:|"∃":"b∩⊃%Xh($&¬*N"N$Y!∩∞-∩:>∩*b:⊃%Xh($&d
NR∞-∩N>Jz"∞VJtz∩∃lhP$&⊗t!l4(M*B∩ε$)l4(L*:⊃lhP4(1¬β.#'S'v9β?C≠Qβ∨?& ⊃3∨␈≠?93.c∪↔IgK?W;>+Il4Ph*BJ|~⊗∩V∀)α≡>≤z9"N%∩&:≥∧~&⊃"u*21%KX4(&∀*≡&8hP&JB%⊃":>$)%α:#X4(&L1α2⊗t:R!"≤J⊃%yααR"⊗ph($&d
NR∞-∩N>J|r>∩∀D~NI"≤J⊃%lhP&:∩⎇~Rε∞]">A"d
NR∞-∩N>IKX4(&L1α:⊂\rV20E∩⊗∞>∀!αR",p4($L∩⊗≡&ph($&∧zBNRZB2εN$~VJN⎇⊃%l4PH&BV≤BNR-DbεNR≥*JN>∩b:>∩+RN>:\r∩u%Xh($&,r⊃l4PJVB∩
"∃l4PJ⊗:⊃Xh(4*¬∩>∞⊗%*J∃α<z∩ε⊃E~RJ&t9α∞&"B:V2bI%l4PJ
⊗≡Lp4(&∃αRI"tz∩∃%∧r⊃l4PJ&→αd*:≡RBB∞&⊃KqAαRD*84(HJ2εN$~VJN⎇∩}:>$(b∞N∩B∞&⊃KX4(&t"}NR ~.R>αB2εN$~VJN⎇⊃%l4PJ&→αt n:Vd`bJ⊗≤zJ⊃α$B⊗84PH&
⊗<J84(HJB>B≥"-"2
~R∞V∃~>I%Xh($&¬*N"N$Y"2ε≥"∞VJ≤zI2:|"∃j∩ "n:∩jIl4(HJ⊗:⊃Xh(&V∧"εR∃Xh(&⊗t!l4(hRBJ>≤*∩VJ*α⊗2∩-⊃"NR∀J:≥α≤J⊃":,b1%%Xh(&
,:&8Q!∃∃¬J%∧t|HU∩∧tG1PPL_d∧d,hzDBD9_BKs∧
DD,aQ HLH~5$≥Z*4⎇∃yit$)λ:5∩D9_BKXQ!∀t%z:D ≤:IuαDH~5$≥Z*4⎇∩↔1PPL_d∧t!9jTda
(T≤⎇(D¬$DYaPPH_(T<LaQ HM z¬≥$5 D
≥H:U∃≤z%∪Xh!⊃∃¬-9
5$Z H∃≥$:Z%≤⎇%Id|$W(T∃∀{9d%j↔1PPH_Yd#XQ!∃-∧H~D+XQ!∀,tG1PPh*
$|≤XJU∀
→u,txZ"E≥J)∀t:λ9∀"DhYDbJ↔1PPL(XtLpβ"B**∃∀J iq⊃*$ Q∞c!!21H H3Qu ¬⊂r1¬↔Lλ∃ λ3C"A⊃3⊂4jHu4TizWsShH&⊂tj%⊂r1¬↔c"B)h↔tuλ_rq∪j¬∪⊂4jHu4TizJ.c!!21H hεsU)Iε∀Q(9tQλ
I⊃3C!!"0Q(y3C"A⊃4∪t
:∩j∪λ~u⊂u**stJ'1"B"*
4r∀jIj∪⊂*:⊂u4J9tK∪Ix⊃.V(*SvsHK*.c!!"13HGc"B*Z⊃⊂5λWc"B(YQ∞c!!"@↓D(→9
≡~;Yd
|≤nD |≥<m¬λ_|
} λ_nM| λ <>_z¬D_|[mM≥< ∧ |[{
L≠⎇{G1"C"J*∃∀J iq⊃*$
∀SphX∃4Q$λt∃4i¬∀T∃
%∪SqλU(∃P)Gtu∀I→Qh⊂i_
∪U)I
*.aQB0Q(y3C"A→1H⊂i_εsU)Iλ∃∩λYH∪⊂*:⊂u4J9tWsIx⊃&⊂j:J⊂r(E.c"A~∃4r
:∩j∪λ~u⊂u**stK
h3
.aQB54λH5⊃.aQB4Q*J4SJ
h3
.aQB13HGc"C!*T∃∀E Sq⊃%∀∀∀Sh81∃4HT⊂t∪j¬∀u∀I→Qh⊂i_
∪U)I
*.aQB0Q(y3C"A~T∃∀E Sq⊃%∀∪Q∞aQB21Dλr1εij3∪λ
I⊃3H H4u⊂jZTstKySq⊃#λttJλ91
.aQB3Q z∪t∀jIj∪⊂*:⊂u4J9tJ.aQB54λH5⊃.aQB4Q*J4SJ h
.c!!13Qπ1"C"AQTT∃
%∪SqλU(∀∀Ixq1∃*((⊂u z
∀u
)3Qhλ91
∪JY∪
*'1"B0HXr3C!!4T∃
%∪SqλU(∪Qπ1"B2(d⊂r1β9U3∪∧
∩⊃3D ⊂4uλ:4Tsj+sSqλS⊂ttEλr1
'1"B3HKtu⊂(9u∪t¬ ⊂4uλ:4Tsj%.c"A~4⊃⊂*H.c"A~Q5∃*)J∪Q¬↔c"B(YQ∞c!!"TT
JJ∪ShH*(∀
)pq1
ZQ(⊂i~∩
∩)j⊃1q*$∩* ¬↔tu∀I→Qh⊂i_
∪U)I
*.aQB0Q(y3C"A~T∃∀E Sq⊃%∀∪Q∞aQB21Dλr1εij3∪λ
I⊃3H H4u⊂jZTstKySq⊃#λttJλ91
.aQB3Q y5∩⊃)J
∩+ H4u⊂jZTstE↔c"B*Z⊃⊂5λWc"B*(5∃4Ie∪Q
'1"B1)h∞c"AQT∀Sh81∃4HT⊂q6λ9
∀u
)3Qhλ91
∪JY∪
*'1"B0HXr3C!!21Hλ91εsJY∪λ∃ λ3H∪λ~u⊂u**stWiiq⊃&λ:tJ⊂i_
.c!!16⊂i
u∩j H4u⊂jZTstE↔c"B*Z⊃⊂5λWc"B(YQ∞c!!"TT
JJ∪ShH*(∀
)pq1
ZQ(⊂j)s∪∃*¬∀u∀I→Qh⊂i_
∪U)I
*.aQB0Q(y3C"A~T∃∀E Sq⊃%∀∪Q∞aQB21Dλr1εij3∪λ
I⊃3H H4u⊂jZTstKySq⊃#λttJλ91
.aQB3Q zSs∪
Z∀u∩e ⊂4uλ:4Tsj%.c"A~4⊃⊂*H.c"A~Q5∃*)J∪Q¬↔c"B(YQ∞c!!"TT
JJ∪ShH*(∀
)pq1
ZQ(⊂j)s∪⊃ zsJ∀jJR3Qdλr1
j3∪
%↔c"B((1r3AQB4T
JJ∪ShH*(∪HGc"B)_H⊂r(CsU3 D∃∩⊃)d∪⊂4jHu4TizWsShH&⊂tj%⊂r1¬↔c"B)h↔tSiI⊃∪uiju∩j H4u⊂jZTstE↔c"B*Z⊃⊂5λWc"B*(5∃4Ie∪Q
'1"B1)h∞c"AQ@↓D(→9
≡~;Yd
|≤nD 8\{
|kλ≤L]≠≠xeD_8\n<= λ∞,;≤y.Gc"C!*T∃∀E ⊃Q3
E(∀∀Ixq1∃*((⊂0J9∪pj
:∀R3Ht∪Q∀jλjλSG$J*.aQB0Q(y3C"A~T∃∀E Sq⊃%∀∪Q∞aQB21D ⊃3QjI
∪Q
:⊂j/F∧∃∩⊃)a"B")h↔sShH4t⊃(5∪Q∀jλj#"A_3∀q!QB"3HKtu⊂(9u∪t¬∧⊂u4Iiq⊃*'1"B2(d∪Q∂)j3∪ε
(0stHD∃∩⊃)d⊂0Sj*
λH Iph∪hd∃r⊂*GhJ.aQB4Q*J4SJλ_Tv⊃HU∪Q
%↔c"B(YQ∞c!!"TT
JJ⊗⊃HY∃
(
Spq(J4Q(
(3∪∪h5∀u∀I→Qh∪HJt⊂j∧)NHJ%↔c"B((1r3AQB4T
JJ∪ShH*(∪HGc"B**∃∀J λQ3∃¬∀⊗⊃Q'1"B2(d∪⊃3Hz∩
∪HJt⊂j'fλ∃∩λYC"B!→Q↔sIx⊃4tλXj∪Q
:⊂j#!!13∀hQ"B")h↔tuλ_ru∪j¬ ⊂u*)Sq⊃%↔c"B)_H∪QπYU3∪β
Q0sj(λ∃∩λYH⊂0IzU
λD ∪ph xH∃rλ~∂hJ'1"B6λh7sQ*s⊗⊃Q)J∞c"A_4TU
(3J⊗λh3∃∞KλVv⊃H[+∪ShH.V⊃K9Q↔*'1"B4HZ∃0SE ⊃Q*'1"B1)h∞c"AQT∀Sh81∃4HT⊂0Tj85
∀jJR3Qd Q∀tλ5λSND%+⊂4jIj∪U)Iλ*.aQB0Q(y3C"A~T⊃∀E Sq⊃%∀∪QεaQB4T
JJ⊂ #⊃f*∀P⊗#"]FB∧dc⊂∪"g#j∩∀'")T!T←_λ*$"gβE∧Dg⊃/c'b⊃ih"aJ'")h⊂TFE∧Qd)bFB∧Dg"↔ij aRh'h∀ !ji'∪b"T]CE∧dcλ'"≡g∃f& )⊃agi"λ*$"gλ a'i∃∀⊃⊂&∪aP'cλ+d j∂Q∀]FB∧dc⊂∪"g#j∩K)>0 THEN
LASTARITH←NAMEDASTK(ASTK);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
XFE←STACKTOP(LASTARITH);
IF RECTYPE(XFE)≠LOCATION(XFELT) THEN
ABORT(" IMPROPER TYPE ");
SETABSXF(ND,XFELT:XF[XFE]);
UPDATE;
END;
PROCEDURE RELSET(STRING NDSPC("N:"),ASTK(NULL));
BEGIN
RPTR(NODE) ND;
RPTR(XFELT) XFE;
IF LENGTH(NDSPC)>0 THEN
ND←NODESPEC(NDSPC)
ELSE
ND←STACKTOP($CURNODE);
IF ND=NULL_RECORD THEN ABORT(" LOC OF WHAT?");
IF LENGTH(ASTK)>0 THEN
LASTARITH←NAMEDASTK(ASTK);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
XFE←STACKTOP(LASTARITH);
IF RECTYPE(XFE)≠LOCATION(XFELT) THEN
ABORT(" IMPROPER TYPE ");
ARRTRAN(NODE:XF[ND],XFELT:XF[XFE]);
UPDATE;
END;
! motion operations;
PROCEDURE RAADARM;
! This procedure @→S]If↓←khAβ;#↔K*βS#∃ε K5β∞≠SWπdceβ'~βπ;⊃π##↔aQ'∨&},W
πM
↔~εn,⊗n* ≡2π& Tε∞↔=yG/&T g,;9(
|β⊂:4→P0y6H4w⊂ 4he~∃MkEaCIhAQS∃eCeG!r\`,hP4)↓α↓↓↓↓αα
,y→`hPα3uid∀Q0)D⊂4TH≠(⊂6λkl.M%F.M↔'1"B2(htH⊗*h4Th
I⊃3PaQHλλ∧∧λλλ∧∧λλλ9⊃0Q%λ6⊃Vf∃α_nDNβ ! AXF is actual arm frame;
EJDC
IFCR BVERS DHENC
READ_BLUE(AXF);
EN@ ε~(∪β1
ljXi;|`v~∀@@@@@A' Qβ¬'1_Qβ%~1β1 Rl~∀∪+A β)
l~∀@@@@@@↓ ⊂~⊃Xh(4*¬∩>∞⊗%*J*λyt
∀U
$, Dλ∃∃∀≠∀∧∃De↔0hPQ$∩¬&
≡2ππ-x6.'↑,Rεn}lW
πM Rε∂-Tπ&zλ+∧3XQ!PPL(XtLpβ"B)_Pt@ ~Q0 )H*$"g⊂FE⊂⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂∪kg⊂)⊃`f⊂ T) lP⊂,#*"Sh-X]
⊗_]~↔]FE⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ i)*∀ g∀!⊗#*"fT⊗!,#
]FE⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ↓bl"PT↓fgU"T!,⊃*"fh
T]P⊂λ⊂⊂⊂⊂λ⊂⊂⊂⊂λ⊂⊂P6[{2P0\4¬ to BXF;
READARM;
EN@ ε~(∪∪
πHA¬- I&A)⊃∃≥ε~∀$@@@A¬¬∨%( E¬→+∀A- ¬M∪∨9∧~ε::⎇!α6>4)αεJjαf⊗Q∩Il4(J↓↓↓α,r∩ 4PJ⊗:⊃Xh(4*¬∩>∞⊗%*J* Yu4 _*2E≥J)∀t:
:D\LE e,dE∃∪Xh!Q"
¬>↑πε␈<Tπ&FT ⊗↔≡⎇NW&* n&∞nT
v2α∞Mε*α ≡&jα∧
↔
∧≠λ`hR∧∧ααα∧∧ααπM Rε∞.9vg/LTε7⊗≥\Rε}d∧α⊗n}M⊗}r$∧αεO4 UD0Q$ααα∧∧ααε≥lBπ>T∞v∞wD∞FF*
lW:ε]}FN}d g⊗∞\Tπ&z ,R∧uλe`hR∧
v*πM W⊗.m}&*ε ≡f*πMtε≡}↑∞W&*∞Mε*εl↑rε∂-Tε7⊗≥\R∧∃λe`hPQ$α¬&
≡2εn\≥g~α [∧2βTλ∃D2¬$¬Bπ⎇ W⊗* ∧εO~∞Mε*εM≡7εf≤<Vn.nDπ'⊗≥n2ε⊗↑Nv..d∞FF(Q$αε∂-Tε∞vD∞FF*
]w&N⎇dε7⊗≥\W~r
=r¬BπTεNwl↑'≡*λ≠∧2J¬$∧mDed¬&F]d∧uDdπR∧∃λdαR¬∧↓PRα
=rb∧+λbβj k∧2α$
⊗w6↑.6*E¬∀βj∧j8bαR
≥g6/.<RDmλe∩αRλ≠∧2s1Q hP_(T<LaQ"αα∧∧ααα ztr¬(X∀b∧~*$
J [∧5[↔&Rc &KR`h!⊃∩αα∧∧αα∧≠λe[ &UC SKU@hP⊃∀ααα∧∧α∧∃λk3 SUF∪S%UAPPH∀∧ααα∧∧¬$m 6∪S*F↔#%k1Q"αα∧∧ααα
*¬%∩ z∧t"∀
∧uDg1PPL_d∧d,hzDBE:I4L"↔fα¬$λY`hP⊃→D
≥H~$M$ yd lXH∃≥$5
5$\_E∪Xh!→∀2∧H~5$
)~DCljYDaE(X4⎇∀D
DD,aQ HL_)u∃"∧$∧tz
:D ≤4 ∀tMI_∀dM(XB∩K1Q LLdλ5-∀Yzd+ljYDaE(X4⎇∀D
DD,aQ HL_)u∃"∧$∧tz Yu$Lyd∧5∀→XR∧$Xi∀t,D∧"KXQ!∀L2T∧≤|jJ$|dHXAD∃∃λ5-∀Yzd*d~)RJ¬IλTph!⊃∀ ∀z*BB∩λ8∀ttzD∧≤|jJ$|bλj$ lT∧"4txHSU∧h→T-\:Z$l⎇h[RKXQ!∃-∧J:U¬¬(Z5≥⎇ZλE≥-
$-≥56∪Xh!~$, H~$kX⊃⊃∩α
|W"ε
⎇f/∨D∞f∞g\W0hR∧∧ααα∧∧∧ ∃;λbD
)UD
De↔2αα∧∧ααα∧∧ααα∧∧ααα∧∀∧
Dd
↔~ε≡-Rε7,≥V+XQ$ααα∧∧αα∧_*5D2λ:U∀lzhRdmλe∪Zα∧∧ααα∧∧ααα∧∧α
∧[λbεO4
V␈&≥⎇bε7,≥V+XQ$ααα∧∧αα¬ k∧5⎇:H∀≤]IzαDd~:D
∀~IαKZ∧∧ααα∧∧α
¬ k∧2π
⎇⊗w'4∞Fz∧kλbεv↑tεn␈M≥vrεn,⊗n+1Q LLd
$,≥K~∧*E k∧2I9It≤
I→trEλhTe"∀
DD,aQ HL_)u∃"∧*D⎇α xbα∩j:D ≤7)∀%\H~5$
)~DEjd$∧t⎇Dλ∩¬%(→e~r%↔0hR∧∧ααα∧∧∧LukλeD2 [∧2d≠λbe$Z¬∪Zα∧∧ααα∧∧ααα∧∀¬$m∧πRεNnlW↔≡U UD2∀¬"∧uλg0hR∧∧ααα∧∧¬D5λiU,b λd,eG+∧5] k∧5jJIUαd+λbKZ∧∀∧∃DdπR∧
λdαRε≥nf/↔<U∧mDe∀αR∧kλcXh!_t|
)U∧∃De↔0hP~Z∧%≥Z
¬∀-:;u-∧J:U¬¬(Z5~k↔1PPMZλD
$W1PPLYhCXh!Q hU
)t≤,JZ$*∧Yzd-∀Xe¬≥%)→d:¬:I4L" jTdb∃↔0hPQ$∩¬∨↑∞ε␈≡T∞FF* ≤'≡}N↑F*εn,⊗n*
|bα↔,\f/⊗]l6*∩
≡2¬∃λaPRα ≥f"π|Tε∂⊗T vO6]dε
εM≡7εf≤<Vn.nD∧%Dd∞&.f≡M↔6*∞Mr¬∃λaPRα∞>V≡B∞Mε∂"∞Mε*εl↑rεn}M⊗}r n&∞nT eD2
↑W∨" ,R¬∃λdαR∧Kλbph!Q"α¬M
↔~ε\\⊗w~ k∧2βT
%D2¬$∧%Dd ⊗v"∞Mε.r <⊗fb
]w6.≤.2ε∂4 &.6},RsXQ!PPL(XtLpQ$ααα∧∧αα∧zyb¬∀X→B∧
*(∃J¬+λe[ &UC SKW0hR∧∧ααα∧∧¬∃¬J%∧⎇∧hE∩¬∧kλcXh!→∀2∧HYd=$¬
5$\_E∪sα
I∧,pQ!⊂Ld~:D
∀~I¬|t→XT$
:I2E≥I9∀"K1Q LLd D
≥H~$M$πYe,dC
$,≤z(B¬$λY`hP⊃_∀∀⎇*Eα∩∧it¬≥$_92∧Li~DL I≠$,"%↔0hP→_b∧≥Z)T⎇4WYe,dC
$,≤z(B¬$λY`hP⊃_∀∀⎇*Eα∩∧it∧l⎇I→tr∧j(∀l*λHT4LhXBα∩↔1PPL_d*∧9ye%∀yID,!λ+∩D≥Z)T⎇4UH∃∀j∀
DD,aQ HL_)u∃"∧$∧≤ iiu"∧9ye%∀yD∧5∀→XRα∩iit$+* d l[85-∀Yzd-j↔1PPMZλE≥-
$-≥;zU∧%:Z¬¬∀Z:2[ 1Q"αα∧∧αααλ_%≥Deλ5-∃(Xbe∃λe∪Zα∧∧ααα∧∧ααα∧∧ααα∧∧αα
+∧2ε≡4π⊗.l↑&.v<Tε7⊗≥\SXh$∧ααα∧∧α¬∧kλe⎇≥H_4]$z¬∧d
:H∃∀MI¬∪Zα∧∧ααα∧∧αα
eD2∞
vNwN4π&zλK∧2εM≡7εf≤<Vn.nG0hP→_b¬∀X:EM∧U
∧uDe∪4d|8~DL|e ∧4,JE∩¬$λY`hP⊃_∀∀⎇*Eα∃$z∧∧|2∧$e≥$_93TLK9D
≥H~$M$ Tb∩∧izB∧
J$ u5d"KXQ!∃¬-9
5$Z H∃≥$~)∃$BIhU9EλhTe"↔1⊂J
∞∞W≡B ∀εv/t∞F.oπ1PRα∧∧ααα∧ ∧5DiZTbE+λbeDhYE#Uλk5∧uλkReDhYE#Uλk5≥$_95$⎇¬ D
≥H~$M$¬≠RKZ∧∀¬$,Z u∃De(ED31Q"αα∧∧ααα Yu4,_*2DuYIBKZ∧∧ααα∧∧ααα∧∧ααα∧∧ααα∧∧ααα∀ Fzε≤.6}g↑LRεn}lRε∂4 ⊗⊗␈lW0hP~ u¬≥I5∧d
:H∃∀MI¬∪XH⊃∀∩π>T
ε␈εT T⎇4X_%~εM|W≡r}Dε≡F≥lv(h!⊃⊂HH⊃⊃∀d
:H∃∀MIπ0hP~Z∧%≥Z
¬∀-:;u-∧J:U¬¬(Z5~k↔1PPMZλD
$W1PPLYhCXh!Q%¬∀x8T%-(T∧l⎇hZ$,b
:E∀Lht¬≥$9_BDuYIBJK1Q hR∀
7/π
}6*πM Rε∞.=vg/LTε7⊗≥\Rε}d∧'⊗.l↑&.v<T"εO4
%D0Q$αε∞lDπ>* ≡&*ε⎇≡f.r ∀ε&O>
F∞≡]\Vw"λK∧2π,]F∂&≡lRπ&t
%D0Q$απ∨\=απ& ≡Bπ& Tεv/t
V␈&≥⎇bε7,≥V*∧kλbεo↑>Bε⊗T UD2¬-⊗w2
+∧2J(K∧2U+λbph'1PPL(XtLpQ$ααα∧∧αα∧zyb¬∀X→B∧
*(∃J¬+λbdmλeE$m 6∪S*F↔#%k1Q"αα∧∧ααα
*¬%∩ z∧t"∀
∧uDg1PPL_d∧d,hzDBE:I4L"↔fα¬$λY`hP⊃→D
≥H~$M$ yd lXH∃≥$5
5$\_E∪Xh!→∀2∧H~5$
)~DCljYDaE(X4⎇∀D
DD,aQ HL_)u∃"∧$∧tz
:D ≤4 ∀tMI_∀dM(XB∩K1Q LLdλ5-∀Yzd+ljYDaE(X4⎇∀D
DD,aQ HL_)u∃"∧$∧tz Yu$Lyd∧5∀→XR∧$Xi∀t,D∧"KXQ!∀L2T∧≤|jJ$|dHXAD∃∃λ5-∀Yzd*d~)RJ¬IλTph!⊃∀ ∀z*BB∩λ8∀ttzD∧≤|jJ$|bλj$ lT∧"4txHSU∧h→T-\:Z$l⎇h[RKXQ!∃-∧J:U¬¬(Z5≥⎇ZλE≥-
$-≥56∪Xh$∧ααα∧∧α∧ *;∧2D:Z%∀,eJ%D2↔4ααα∧∧ααα∧∧ααα∧∧ααα∧∧∩¬∃λdεO~∞,V6/,]f≡* n&∞nW1PPM(X∀$
)W0hP__%≥Deλ5-∀Yzd*d[λbKX⊃∀ααα∀ UD2
≡2εn}M⊗}r n&∞nW1PRα∧∧ααα∧
∧uDkz5$ 9:D⎇α H∃≥$~)∃$B↔4ααα∧∧ααα∧∧∩¬∧kλbπε⎇≥g'~∞Mr∧%λdε&O>
F∞≡]\Vw#1Q LLd
$,≥K~∧*E k∧2I9It≤
I→trEλhTe"∀
DD,aQ HL_)u∃"∧*D⎇α xbα∩j:D ≤7)∀%\H~5$
)~DEjd$∧t⎇Dλ∩¬%(→e~r%↔0hP~
U≤E:I2Dd~:D
∀~IαdtZs¬D4YJBKX⊃∀∩ππ↑=αε
lW:πL]WβXQ$ααα∧∧αα∧_)∀ mYE¬∃DeK∧4,JG%D5: eD5UJDmα↔1PPMλk∧4mYE¬$m¬IUD2Kλd,eG+∧5]:H∀≤]IzαDd~:D
∀~IαMj↔4hR∧∧ααα∧∧∧l⎇hX∀∃~ jTdb↔4ααα∧∧ααα∧∧ααα∧∧ααα∧∧ααα∧∧∩ε&t ⊗↔≡⎇NW&*
]w6* ≡2ε∞-}f+XQ!∃∧⎇
:DZDH~5$
)~DBK1⊃⊂J
∞|RεF} R∧lzhT ∃4 F}/=dw"ε= ⊗v>QQ HH⊃⊃⊂HLH~5$
)~DCXQ!∃-∧J:U¬¬(Z5≥⎇ZλE≥-
$-≥5V∪Xh!~U∧$~HSXh!_Tt#1Q hPQ*¬∀|8XE-∀Tλe∀ W1PPh$⊂¬&F≡4ε7⊗\↑2π& Tε∂⊗T f␈∩εTπ≡∞=⎇f'~D G/⊗≥lrπ>
≤6BπM≥V*πM Rπ/<Z hR∧∞6F␈]LBεn}lRπ& Tε∂⊗T
Fzε∀ F/≡≡,V"εM|6∂&≥⎇bε∞l@ππ/=π&FT
V∞>≤1PRα∞,V"ε.ZG&}edαα¬M Rε∞.9vg/LTε7⊗≥\Rε}d
FF* ≡&jε≡4π&F]`λ∞↑→_= \ C"D∧∩9H
≥\⎇→,≤λ≥~ ↑Y(~.4_(∃
≥9+;n↑λ≥z.M≠⎇=∧∞~→(
\9z0d∞Y9λ∧ ]=≥
⎇Hβ"D∧_Y2-lh≤≥.=→9 ∧
[⎇~
≥Yh~ ≡≤→;N5Lc"AQB0Q(y3C"A~4⊃∀jZ∀∀Q*:wu4λJu4∀
(4tjf↔c"B)_Pt@ ~Q0Td
∩⊃3H1"B(∧∧λq+λ0jhjQ1*'4λλλ∧∧λλλ∧∧λλλ∧∧λλλ$ \Y9$∞~→( ≡[(→M}H
(∞<8{{LNnc"A∀RS THENC
OUTSTR("BLUE VERSION DOESN'T SUPPORT FREE YET");
ENDC
READARM;
UPDSUPPRESS←UPDSUPPRESS-1;
IFCR YVERS THENC
IF ARM_STATUS≠'1000 THEN
ABORT(" TIMEOUT ");
ENDC
UPDATE;
END;
PROCEDURE ATFID;
! This procedure sets the absolute frame of the pointer equal to
that of the fiducial.;
BEGIN
REAL ARRAY FXF[1:5,1:4];
UPDSUPPRESS←UPDSUPPRESS+1;
READARM;
ABSXF(FIDUCIAL,FXF);
SETABSXF(POINTER,FXF);
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
! Not included in this code is type checking and oopsing;
PROCEDURE CONSTRUCT(STRING STKID(NULL));
! This constructs an implicit frame from the top three frames
on the last arithmetic stack referenced. The three frames are
popped off, and the new implicit frame is pushed on.;
BEGIN
RPTR(OPND) OP1,OP2,OP3;
IF LENGTH(STKID)>0 THEN
LASTARITH←NAMEDASTK(STKID);
IF LASTARITH=NULL_RECORD THEN
ABORT(" NO STACK INITIALIZED");
OP3←POPSTK(LASTARITH);
PUSHSTK($OSTACK,OP3);
OPNDCHK(OP3,LOCATION(XFELT));
OP2←POPSTK(LASTARITH);
PUSHSTK($OSTACK,OP2);
OPNDCHK(OP2,LGCATION(XFELT));
OP1←POPSTK(LASTARITH);
PUSHSTK($OSTACK,OP1);
OPNDCHK(OP1,LOCATION(XFELT));
PUSHSTK(LASTARITH,VVVTRANS(POSVECT(OP1),POSVECT(OP2),POSVECT(OP3)));
UPDATE;
END;
PROCEDURE DEFFID;
! This procedure asserts that the fiducial is currently at the ARM frame;
BEGIN
REAL ARRAY FXF[1:5,1:4];
UPDSUPPRESS←UPDSUPPRESS+1;
READARM;
ABSXF(ARM,FXF);
SEDABSXF(FIDUCIAL,FXF);
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
! macro operations for motion, pointit, grabbit, fdef;
PROCEDURE DMKVE(REAL X,Y,Z);
BEGIN
APUSH(TR(0,0,0,X,Y,Z));
MOVEREL;
AFLUSH;
UPDATE;
END;
PROCEDURE DX(REAL X);
DMOVE(X,0,0);
PROCEDURE DY(REAL Y);
DMOVE(0,Y,0);
PROCEDURE DZ(REAL Z);
DMOVE(0,0,Z);
PROCEDURE POINTIT(STRING STKID(NULL));
BEGIN
READARM;
APUSH(ABSXFE(POINTER),STKID);
END;
PROCEDURE GRABBIT(STRING STKID(NULL));
BEGIN
READARM;
APUSH(ABSXFE(ARM),STKID);
END;
PROCEDURE HERE(STRING ID);
BEGIN
UPDSUPPRESS←UPDSUPPRESS+1;
MK_NODE(ID);
GRABBIT;
ABSSET;
APOP;
UPDSUPPRESS←UPDSUPPRESS-1;
UPDATE;
END;
! altrans,alid, aldecs, unique_id;
BOOLEAN PROCEDURE UNIQUE_ID(RPTR(NODE) ND,HANDLE);
BEGIN
! returns true if NODE:ID[ND] is unique for the
subtree homed at handle minus the subtree
homed at ND;
RPTR(CELL) C;
RPTR(NODE) N;
BOOLEAN HAVEHIT;
IF ¬IS_ANCESTOR(ND,HANDLE) THEN
ABORT(NODE:PNAME[ND]&" not descended from "&NODE:PNAME[HANDLE]);
IF ¬SMBSCH(NODE:PNAME[ND]) THEN
ABORT(NODE:PNAME[ND]&" not in symbol table.");
HAVEHIT←FALSE;
C←RLIST:FIRST[SMBL:HITS[SMB]];
WHILE C≠NULL_RECORD DO
BEGIN
N←LLOP(C);
IF IS_ANCESTOR(N,HANDLE) THEN¬
BEGIN¬
IF N=ND ∨ NOT IS_ANCESTOR(N,ND) THEN
BEGAN
IF HAVEHIT THEN REDURN(FALSE);
HAVEHIT←TRUE;
END;
END;
END;
RETURN(HAVEHIT);
END;
STRING RECPROC ALID(RPTR(NODE) ND,HANDLE);
BEGIN
! returns a good unique name for ND in subtree of HANDLE;
IF ND=NULL_RACORD THEN
RETURN("__");
IF UNIQUE_ID(ND,HANDLE) THEN
RETURN(NODE:PNAME[ND])
ELSE
RETURN(ALID(NODE:DAD[ND],HANDLE)&"_"&NODE:PNAME[H
:$v~∀∪∃≥λv~(~∃¬∨=→ β≤↓/)→↔1+∂
vB@TT(TTA[¬IJA]∃GKgg¬erAEdAY←gMCOJA=LA!βI' 7β0Y/)→t\~∀∩$∪%K[=mJACLAg←←8ACfA→KCgS YJ\@(TTTTl~∀~∃M)%∪≥≤A!%∨
+%∀Aβ→)_Q% β0Aβ%%¬2A1 m')%∪9∞A) $v~∀∪ ∂β≤4∀∪')I∪≥∞AM∪≠!→∀A!%∨
+%∀Aπ,QI β_AHRv~∀$∪∪ A])→↔→U∂
A)! ≤A¬∃)+%≤!π- QHRR
∀$∪ →'∀A% U%≤QπY∂0Q$$Rv~∀%'!%∪9∞A'∪5!→
AA%∨π ⊃+%
AI∨!
∨I~Q')I∪≥∞A¬1∪&wI β_A\Rv~∀$@@@@↓∪ A/Q→↔→+≥
A)⊃∃≤~∀∩%% )+I≤PDPλMβ1∪LLDA%=(@DM
,Q.R_DRDR4∀∩@@@A →M
~∀∩%% )+I≤PE%=(PDM¬1∪&LλXDMπXQ.@%2⊃% %Xh(4(M∩⊗ε1¬92B!e"!l4PJNBJLr≥αJ~bN
lhP&∩⊗≤z∩∀b∀zRεRLz1"b2b] % ↓E$B↔1PPL_d¬=$I9E,<T
DD,aQ HM8ZD4⎇)X∃"C∃FrHh!_Te≤QQ HM8ZD4⎇)X∃"C¬FrKXQ!∃∃≥zHb2∩∧'5≤≥yjTdc1Q LLdλ∀∃~
IαKuI→eJ¬IλTrQ!⊂L∀Xy∀ph!⊃∃∃≥z*25∀zHd⎇∀U∧%TD~D"e$¬↔0hP⊃~4≥z%$#Xh!⊃∀,tG1PPL_d∧ ∃5
∧BKjI∀uJ
I∧,pQ!⊂L∀Xy∀ph!⊃∃∃≥z*25≤4j$⎇$iz$jB+→∧
"%J∧BK1Q HM8;r∩R'1PPH_Yd#XQ!∀L2λ_%~Eu↔e$Lk∀¬$DYaPPH_(T<LaQ HM*;u∃~j825∀zHd⎇∀U∧%TD~D"e:↔1PPH~85z∩$'0hP⊃_Tt#1Q LLd D,tzIαE≤5↔Sα¬IλTph!⊃∃∃≥z*22∀i→E∀⎇Id#Xh!→∀2¬zID\eXxR¬$λY`hP⊃~4-$iz$l
Eε∩c~⊃Q L,J8PhP⊃~4-$iz$l
Eεαc~↔1PPM(ZE-∀e
%~2%Jd,≥Iz"B∩h:bEDk6∩c%U∀b∩b$h52Eλk3∩cKU∩2∩D$d≥2 λe[~FKRHh!⊃⊂J2%∃∩∩K1Q L,hG0hPQ*5%∀→hr¬¬)x4,%Z(R∧ JJ$ u5
$, Dλ∃∃∀≠∀¬D2↔1PPM(ZE-∀eλ∀e$e ∧2b*J$ u4%∩KXQ!PU≥J)∀t:
$|≤XJU∀*λ→D5∀→XRE∀X→B∧
*(∃J¬λe∪Xh!~$-%Z)bD JHbEDeD$5∀→XR∩J↔1PPh*:E∀Lht¬¬∀x8T%-(T∧ dHX2E∃
J"DtxHRJ∧hEDD hID*K1Q L∀Xy∀ph!~5%∀→hr∧ _ED%≠1Q L _Kt d_E∧t"Iλ∀t$HU∪Xh!_E≥z(j$ lT∧"4 _Db∪Z$h5∀dg1PPL8~4*∧ixD+T ztdLi8T%\hKR∧|aQ HL(XtLpQ+4LtIId]h_J5|%4h∀L"d$¬zα$h∀d5(→T*DixD+Uλk4t%U∀b∪Z$h5∀dg1PU\j(tdt;Q∀%≥xJ22∀_hdMB∧$d LDd"¬$t∧"4 I_BDtxHST$_K4t%UI∧ tIHRJ2$λ∃"α!Q HH∀d∧ eJ(∀u~ it$++λe\tKU∩2∩ itu∀_y∀$e↔4"4≥)HcXh+:$<$Ii5hLJ;t%~d(∀44≠∧α∩4→_B2∩
Irα∩h→DL" it$+(H∀%\hKRdD→hDd*∀d"∧
D∧ hP⊃⊃∩2∧→JE∀ j5∧t|HW%D59hEjJd$¬∀Ly_DeK4$d≥∀HaPPH_Yd#XQ!∃∀-JZ$rDJ4d≥∀He∪Xh!_Tt#1Q hU(X5-∃9~d*¬:J$Ltt
¬∀|8XE-∀Tλ∀aE:X%%∀XU¬∃¬J%∧t|HU∩∧tEI∧ tIHRKXQ!∀∀,y→`hP~:E∀Lht∧%≠1Q M∃
J"DtxHRJ¬9g0hP_J5| HHT~DhEDD hID*K1Q M≤kyd|$W*4|u9hEkXQ!∃<D→HR¬≤c9e,dC
$,≤z(B∧$qQ HL(XtLpQ!⊂L%;xE~4→C¬≥,*J$,*
9bdD→hDd*↔1PPH~9e|txHST,*)u]≤kW0hP⊃_Tt#1Q M∀ZJU∀rλJ2KXQ!∀,tG1PPh*
$|≤XJU∀*λ→AD⎇ZE¬∃¬J%∧t|HU∩∧tEI∧ tIHRKXQ!∀∀,y→`hP→_b∧ H9βcα
I∧,pQ!⊂L∀Xy∀ph!⊃∀⎇∧Ye∧ d9 t<-H9∧ rD(E≤Z%FαcαF5Cαc¬H∀d,xe∪Xh!⊃∀ dYxezk↔1PPH~y∧LdTλ∀d,xd∧$xQ!⊂HL(XtLpQ!⊂HLzZE≥%%∧$⎇-J
U"∧i→D*α jTdb
Ir∧4z(t-" ~BKj%↔0hP⊃⊃∀ di_E|Lh9¬<c1Q HH→_b∧dYhu$Bλ→D4LE↔Sα¬IλTph!⊃⊂HL(XtLpQ!⊂HH~(Td,~8RD H9αKXQ!⊂HH_→D≤EuV∪Xh!⊃⊂HLIyd+XQ!⊂HH_Yd#XQ!⊂HLYjD-∩λ→D≤BH→D4LEH∀d,xe∪Xh!⊃⊂LLdλ∀d,xd¬$DYd∧⎇-J:E∩B(Ye$-$λd LHXB∩4:)D2K1Q HH_Yd#XQ!⊂M-λH∃$+1Q HLYhCXh!_5¬∀→jBD H9αd A
5,∃J(T*DhEDD hID*J↔1PPLYhCXh!Q%¬∀x8T%-(T∧ aλ9D⎇≤W1PPL(XtLpQ!∀L2λ→D≤Cf∧¬$DYaPPH_(T<LaQ HLzZE≥¬%∧$≤dz9∀t:∧$d di_B4≥)HbKXQ!⊂M∀YHT
≤Uλ∀d≤¬↔0hP⊃_∀d≤ uS XQ!⊂M-λH∃$+1Q HLYhCXh!_Tt#1Q hT9HT uZ∧∧ aλ9D⎇≤W1PPh*
$|≤XJU∀
λ→AE=)~D+XQ!∀ a zU"D:Z$t|HUD≥-*λ∃$B↔1PPb
=v&*∞Mrε.]≡Bε
∞ vNwO∀ε≡}]\⊗v" m⊗f+1Q hU*
E∩DixD*J
$|≤XJU∀
yD$-:C²|e
%¬%% d|$U∀∧t"↔1PPL(XtLpQ!∃∃¬J%∧t|HU∩∧[1Q LLd d#ljYDaE(X4⎇∀D
DD,d
$-%Z)bDuYIAE∀X9u∀"↔1PPL;yd|$ON[ND];
IF K=NULL_RECORD THEN RETURN(NULL_RECORD);
WHILE NODE:EBRO[K]≠NULL_RECORD DO
K←NODE:EBRO[K];
RETURN(K);
END;
RECURSIVE PROCEDURE SAVE_NODE(RPTR(NODE) ND);
BEGIN
RPTR(NODE) K;
IF ND=NULL_RECORD THEN RETURN;
IF PCH<0 THEN
BEGIN
OPEN(PCH←GETCHAN,"DSK",0,0,3,0,0,PCEOF);
PCEOF←-1;
WHILE PCEOF DO
BEGIN
OUTSTR("OUTPUT FILE (NULL TO FORGET IT)=");
PCFID←INCHWL;
IF LENGTH(PCFID)=0 THEN
BEGIN
RELEASE(PCH);
PCH←-1;
DONE;
END;
ENTER(PCH,PCFID,PCEOF);
IF PCEOF THEN OUTSTR("ENTER FAILED"&CRLF);
END;
UPDATE;
END;
K←OLDEST_SON(ND);
WHILE K≠NULL_RECORD DO
BEGIN
SAVE_NODE(K);
K←NODE:YBRO[K];
END;
CPRINT(PCH,CRLF&"MK_NODE(""",NODE:PNAME[ND],""");");
SETFORMAT(0,7);
CPRINT(PCH,"APUSH(",OPNDSTR(ABSXFE(ND)),");"&CRLF);
SETFORMAT(0,3);
CPRINT(PCH,"ABSSET;APOP;"&CRLF);
K←NODE:SON[ND];
IF K≠NULL_RECORD THEN
BEGIN
CPRINT(PCH,"CPUSH(CPOP(""N:""),""D:"");"&CRLF);
WHILE K≠NULL_RECORD DO
BEGIN
CPRINT(PCH,"CPUSH(CURNODE,""N:"");");
CPRINT(PCH,"ELDER;CEXCH;");
CASE NODE:HOWLINKED[K] OF
BEGIN
[INDLNK] CPRINT(PCH,"INDEPENDENT;");
[NRGLNK] CPRINT(PCH,"NONRIGID;");
[RGDLNK] CPRINT(PCH,"RIGID;")
END;
CPRINT(PCH,"CPOP;"&CRLF);
K←NODE:EBRO[K];
END;
CPRINT(PCH,"CPOP(""N:"");");
CPRINT(PCH,"CPUSH(CPOP(""D:""),""N:"");"&CRLF);
END;
END;
PROCEDURE P_CLOSE;
BEGIN
IF PCH>0 THEN
BEGIN
OUTSTR("CLOSING "&PCFID&CRLF);
RELEASE(PCH);
PCH←-1;
UPDATE;
END;
END;
CLEANUP P_CLOSE;
PROCEDURE PSAVE(STRING NDSPC("N:"));
SAVE_NODE(NODESPEC(NDSPC));
! dskin, macro routines, prompt, bcall;
INTEGER DSKINBT;
PROCEDURE IBTINI;
BEGIN
DSKINBT←GETBREAK;
SETBREAK(DSKINBT,";",NULL,"INA");
END;
REQUIRE IBTINI INITIALIZATION;
BOOLEAN BAILTRY; ! *** SO I CAN EXPERIMENT ****;
INTEGER TISUPPRESS; ! used to suppress updating during DSKIN;
INITIALIZE(TISUPPRESS←1);
RECURSIVE PROCEDURE DSKIN(STRING FID);
BEGIN
INTEGER DSKINCH,DSKINBR,DSKINEOF;
EXTERNAL STRING !!QUERY;
DSKINCH←GETCHAN;
OPEN(DSKINCH,"DSK",0,3,0,1000,DSKINBR,DSKINEOF);
LOOKUP(DSKINCH,FID,DSKINEOF);
IF DSKINEOF THEN
ABORT("LOOKUP FAILED FOR FILE "&FID);
IF NOT BAILTRY ∧ TISUPPRESS>0 THEN
!!QUERY←!!QUERY&"UPDSUPPRESS←UPDSUPPRESS+"&CVS(TISUPPRESS)&";";
WHILE NOT DSKINEOF DO
BEGIN
LABEL CHUNKIN;
STRING QQ;
QQ←NULL;
WHILE LENGTH(QQ)<200 ∧ NOT DSKINEOF DO
QQ←QQ&INPUT(DSKINCH,DSKINBT);
CHUNKIN:!!QUERY←!!QUERY&QQ;
IF BAILTRY THEN
BEGIN
INTEGER TIX;
EXTERNAL PROCEDURE BAIL;
TIX←TISUPPRESS;
UPDSUPPRESS←UPDSUPPRESS+TIX;
!!QUERY←!!QUERY&"!!GO;";
BAIL;
UPDSUPPRESS←UPDSUPPRESS-TIX;
END;
END;
IF NOT BAILTRY ∧ TISUPPRESS>0 THEN
!!QUERY←!!QUERY&
"UPDSUPPRESS←UPDSUPPRESS-"&CVS(TISUPPRESS)&";"
&"UPDATE;";
RELEASE(DSKINCH);
END;
RCLASS MACRO(STRING ID,BODY;RPTR(ANY_CLASS) NEXT);
RPTR(MACRO) MACRO_LIST;
STRING LASTMAC; ! name of last macro defined or called;
RPTR(MACRO) PROCEDURE MFIND(STRING ID;BOOLEAN CONSON);
BEGIN
RPTR(MACRO) M;
IF EQU(ID,NULL) THEN
ABORT("macro name not supplied");
M←MACRO_LIST;
WHILE M≠NULL_R@ π∨IλA ≡4∀∩β¬∃∂∪≤~(∩∪∪ ↓ #*Q5βπ%≡i∪ 7≠tY∪λR↓)⊃ ≤↓% )+I≤Q~Rl~∀∩∪5?⊂⊗ε≥∩=j:-BRn6kX4($L*:⊃lhP&&→∧~> 59yb¬$λY`hP⊃_$,<→aPPH→[tt-s
$,≤z(BDl_:$zK1Q HLX_5∀{)_E\m[y∀#XQ!⊂Ll_:${Th[¬%\Y[tl :)qDd~:CXh!⊃∀l :)qDd~:E|k1Q HLYhCXh!~$-%Z)bDj↔1PPLYhCXh!Q%¬∀x8T%-(T∧l$Xj∩E≥J)∀t: _Bd∀xK∩KXQ!∀∀,y→`hP~*¬%∩ X∀≥∀u∀∧kXQ!∀m|Xi∀t" _Be%*XRKXQ!∀l :)sT∀xK∃\m[x$|%↔1PPLH~5$l_;tL#1Q L⎇ZJ5%∩ _B2∩λHT4LhXBrα∧$d≥∀He∪Xh!_Tt#1Q hU
)t≤,JZ$*∧XHT2E:J$Ltt ∀"DjYDbJ↔1PPL(XtLpQ!∃∃¬J%∧l :)rJ∧W1PPL[
D-∀h→B∧LjHT<-$β¬≤\~ββXh!→∀2∧izB∧-~U∧L"IjTdb∀
DD,d D
≥IX∀≥|_G0hP→[tl4→hBDd~:Dl 5JE∃,U↔0hP→zU%≥J%α∃%~λR∧Ld T ≥)t∧∀|K∃bαCH→E#r
y∧,rλItt*↔$"KXQ!∀d|HXBDl_:${T)xEM\[U∪\l_:${T)xEM\[[tu,IG0hP_Ir∧l_:${T)xEM\[[tl :)sT∀xK∃\mTi∀t≤
y@hP⊃~Tu$→D↓E≤9~↓Cl→JCXh!→u-%:J"DLDd"∧$Xi∀t,Edαα∩h:$d2↔1PPMZλD
$W1PPLYhCXh!Q%≥%)→d:¬
)t≤,JZ$*∧X_4t XZ3Xh!_$,<→aPPM:J$Ltt
3Xh!~%¬%% T ≥)u∩∧k1Q M≥yjTdc1Q LmyX∀≥∀s DM≥G1PPMy ∀d* S4u,IC¬∀,9z$"∧IqPPH_(T<LaQ HM;z22∩∧$dl :)sTLK9UkXQ!⊂LmyX∀≥∀w)d-EK9UkXQ!⊂L,hG0hP~(U%-)e¬~K1Q L,hG0hPQ)∀u$XxU∩∧Z
D⎇β9→dM$_→DMTU U¬$z rk
↔1PT$Xi∀t* Z∧l
πV∪ββ1Q%≥%)→d:∧~*$
J Z¬≥[π)U∧l≠ SXh*
$|≤XJU∀* Z¬-≤¬
5%∀→hr¬~↔1PPL(XtLpQ!∀L2 Z¬$⎇πYU∧l≠∧¬$DYdhP⊃_∀∀⎇*Eα∃∧IIu2∧→d∧m¬Z9α∩K1Q Lm
;4m¬Iz¬|m
Iuα[≠[u≠XQ!∀,tG1PPh*:E∀Lht¬¬∀x8T%-(T∧m∧xZBDLjHT<-$ ∩KXQ!∀∀,y→`hP→≠tm¬IzαlK1Q LLd ∪cα z"∧KiZ∧l
∧
DD,aQ HL_)u∃"∧)∀t$[∧∧⎇-D t2¬(→d<*
Ir∧mλxU"∩↔1PPM(ZE-∀e U¬≥9≠RKXQ!∀,tG1PPh*:E∀Lht¬¬∀x8T%-(T∧mβπ:$-%Z)bDmλxU"C¬∃∪Xh*:E∀Lht¬¬∀x8T%-(T∧mβ↔:$-%Z)bDmλxU"C∃∃∪Xh*:E∀Lht¬¬∀x8T%-(T∧mβ':$-%Z)bDmλxU"C%∃∪Xh*:E∀Lht¬¬∀x8T%-(T∧mβ7:$-%Z)bDmλxU"C5∃∪Xh!Q%∀,:Z%≤MhT¬¬∀x8T%-(T∧l≤→IBE≥J)∀t: _BDuYIBJK1Q L∀Xy∀ph!_UE$Z)d b
:E∀Lhtα
~XU∃K1Q M∃
J"Dl_:$zJ W0hP→→e$,xZ"¬$≠π0hP→_b∧tzD∧-
U ∀"djYDbJ
I∧,r H∃≥$X_5|LG1PPL[yT4LhE∧d
:IT ~Hh∀e≤U↔0hP→_b∧kYjTda
(T≤⎇(D¬$DYaPPH__$⎇∃E∧$l :)rα∩i_B2∩ iu"∧izTt"%↔0hP~I∃E⎇I~5-¬
(U≥≠1Q M-λJ5-¬
(U≥≥zZ∧%≥Z
¬∀-:55$Mπ1PPJ∀~∃,-+≠tl :)sT∀xK∃\mTd#Z
_ysZ∪1Q L∀→→CXh!~U∧%:Z¬¬∀Z:5⎇-λJ5-¬
(U≥~ZI∃CXQ!∀d
:IT ≥yX∀≥∀w)∀%\[W0hP~Z∧$
HW0hP_Yd#XQ!PU≥J)∀t:
$|≤XJU∀*
~∃≥%%
5%∀→hr¬~↔1PPL(XtLpQ!∃≥%)→d:¬:70hP→→e$,xZ"∧≠1Q M≥;t"∩∩'1PPMy ∀d* HTt=I¬¬~Kf∧∧$xQ!⊂L∀Xy∀ph!⊃∀≥|IzαE~↔1PPH→_b∧≠T$"∩∩
I∧,pQ!⊂HM:;u≥~d$"∩∩$!PPH_YE≤(Q!⊂HM:;u≥~h70hP⊃_Tt#1Q M≥;z5~2$$"∪XQ!∃∀-JZ$rE:5∪Xh!_Tt#1Q hU
)t≤,JZ$*∧Z8∃4*
:E∀Lht∧L" jTdb∃↔0hP_(T<LaQ M∃
J"Dl_:$zJ W0hP~
$|≤XJU∀* Z4
4V↔0hP⊃_$,<→aPPH→zU%≥J%α∃≤~i∀t:∧$dl :)sTLK9Uj2$
Dzα$j∧≤4_Dd≥∀He∪Xh!⊃∀≥¬)→e"Eλ9αb∀XHT5
∧%E
:J"Dl_:${T_K4mj∃D"b∩AQ HH⊃~∃
≥J%∧l :)sT∀xK∃\mU∃B∩K4%D≥∀He∪Xh!⊃∀,tG1PPh!→∀2¬λ9βcα
I∧,pQ!⊂L∀Xy∀ph!⊃∀⎇∧Ye¬∧≤ xt-$9λ∀rb(J4Z∩F¬Cαc5FαcαJλ4,|e↔0hP⊃~∧≤,xkrk 1Q HMy ∀d*
λ4,|dλDxh BEGIN
OUTSTR("OUTPUT FILE (NULL TO FORGET IT)=");
PCFID←INCHWL;
IF LENGTH(PCFID)=0 THEN
BEGIN
RELEASE(PCH);
PCH←-1;
DONE;
END;
ENTER(PCH,PCFID,PCEOF);
IF PCEOF THEN OUTSTR("ENTER FAILED"&CRLF);
END;
UPDATE;
END;
IF EQU(ID,"*") THEN
BEGIN
M←MACRO_LIST;
WHILE M≠NULL_RECORD DO
BEGIN
MSAVE1;
M←MACRO:NEXT[M];
END;
END
ELSE
BEGIN
IF ¬EQU(ID,NULL) THEN LASTMAC←ID;
M←MFIND(LASTMAC,FALSE);
IF M=NULL_RECORD THEN
ABORT(ID&" not found! ");
MSAVE1;
END;
END;
STRING PROCEDURE PROMPT(STRING S);
BEGIN
OUTSTR(S);
RETURN(INCHWL);
END;
RECURSIVE PROCEDURE BCALL(STRING S1(NULL),S2(NULL));
BEGIN
EXTERNAL STRING !!QUERY;
INTEGER UPDSSAVE;
PROCEDURE UPDSUPREST;UPDSUPPRESS←UPDSSAVE;
CLEANUP UPDSUPREST;
UPDSSAVE←UPDSUPPRESS;
UPDSUPPRESS←0;UPDATE;
OUTSTR(S1);!!QUERY←S2;
;BAIL;
END;
! tree_string, csr_string, astk_string;
BOOLEAN SHOWXFS;INITIALIZE(SHOWXFS←TRUE);
BOOLEAN SHOWLINKS;INITIALIZE(SHOWLINKS←FALSE);
STRING SIMPLE PROCEDURE TBLKSUPPRESS(STRING S);
BEGIN¬
! a quicker way is to usE SCAN, buT I don't want to require
any break tables;
STRING SS;INTEGER I,J;
SS←S;J←0;I←0;
WHILE LENGTH(SS) DO
BEGIN
I←I+1;
IF LOP(SS)≠" " THEN J←I;
END;
RETURN(IF J=0 THEN NULL ELSE S[1 FOR J]);
END;
SIMPLE STRING PROCEDURE CVGX(REAL R);
RETURN(IF R=π THEN "π" ELSE TBLKSUPPRESS(CVG(R)));
STRING BLANKS;
SIMPLE PROCEDURE INIBLANKS;
BEGIN
BLANKS←" ";
BLANKS←BLANKS&BLANKS;
BLANKS←BLANKS&BLANKS;
BLANKS←BLANKS&BLANKS;
BLANKS←BLANKS&BLANKS;
END;
REQUIRE INIBLANKS INITIALIZATION [0];
STRING PROCEDURE TSTR(REAL ARRAY XF);
BEGIN
REAL W,PH,TH;
DECODE_ROTATION(XF,W,PH,TH);
RETURN("TR("&CVGX(W)&","&CVGX(PH)&","&CVGX(TH)
&","&CVGX(XF[1,4])&","&CVGX(XF[2,4])&","&CVGX(XF[3,4])
&")");
END;
STRING PROCEDURE OPNDSTR(RPTR(OPND) OP1);
BEGIN
INTEGER RT;
RT←RECTYPE(OP1);
IF RT=LOC(XFELT) THEN
RETURN(TSTR(XFELT:XF[OP1]))
ELSE IF RT=LOC(VECTOR) THEN
RETURN("VE("&CVGX(VECTOR:X[OP1])&","
&CVGX(VECTOR:Y[OP1])&","
&CVGX(VECTOR:Z[OP1])&")")
ELSE IF RT=LOC(SCALAR) THEN
RETURN("SC("&CVGX(SCALAR:VAL[OP1])&")")
ELSE IF RT=0 THEN
RETURN("NULL!RECORD")
ELSE
ABORT("CANNOT EDIT TYPE");
END;
STRING PROCEDURE NDNAME(RPTR(NODE) ND);
RETURN(IF ND=NULL_RECORD THEN "λ" ELSE NODE:PNAME[ND]);
RECURSIVE STRING PROCEDURE TREE_STRING(RPTR(NODE) ND;
INTEGER DEPTH(0),MAXDEPTH(999));
BEGIN
RPTR(STACK) CSR;
STRING TS;
INTEGER L;
DEPTH←DEPTH+1;
IF DEPTH>MAXDEPTH THEN RETURN(NULL);
TS←NULL;
FOR CSR← CURSORS DO
BEGIN
INTEGER PDP;
PDP←STACK:PDP[CSR];
IF PDP≥0 ∧ STACK:A[CSR][PDP]=ND THEN
TS←TS&STACK:ID[CSR];
END;
L←DEPTH*4-LENGTH(TS);
IF L<0 THEN
TS←TS&CRLF&BLANKS[1 FOR DEPTH*4]
ELSE
TS←TS&BLANKS[1 FOR L];
TS←TS&"-+*"[1+NODE:HOWLINKED[ND]FOR 1]&NODE:PNAME[ND];
IF SHOWXFS THEN
TS←TS&" at "&TSTR(NODE:XF[ND]);
IF SHOWLINKS THEN
BEGAN
TS←P &L 7<DM9 ≥β≠∀Q≥∨ ∀u β m≥ :R_DXαD→≥ ≥β5
Q≥∨⊃
u'∨97∃ :$~∀∩∩$LDY>λM≥ ≥¬≠
Q≥=
`*,∩J>nt"u%→∩`e ~t":ε6*B:>∩+Rf
J⎇Z:∩uJ1
`*'1PPH_Yd#XQ!∃%≥zJ24≥)HcXh!→d%|ixD+U9ye\tKW0hP~y∧LdT d!\jYDaE(X4⎇∀DλDzQ!⊂L∀Xy∀ph!⊃∃%≥zJ25%(XQE≥J)∀t: hBd$Z
DBdX≠∧$-
IαKXQ!⊂LtKyd|$W(T∃∀{9d%k1Q HLYhCXh!~$-%Z)bE%5↔0hP_Yd#XQ!PU≥J)∀t:
$|≤XJU∀(⊂tj#∀u∀I→Qj∀J
∀J∀jH0rj$λttJ'1"B0HXr3C!!23UλXq4H ↔c"B*:∀R3Ht⊂tnaQB4T
JJ∪ShH*(∪HGc"B(:wtuλ_rnR(KpttKTPtSλgc"B(itH∩+zu⊂0i7T⊃∀ 8ttW$
u⊃4∧¬,(∃)j∩3λε∧⊃∪c!!"0Q(y3C"A⊃23UλXq4H
*∞c"A⊃0twh:iPuJ5∩*)D'HIUλ_Nc"A⊃3Q↔j:⊂0rg(6ptj+6r7'1"B")_H∪QπYU3∪β
Q0sj(λ∃∩λYC"B!⊃0twh:iHO ]<≥≡'dIPtIHC"B!_3∀q$ 1H
*↔tQ(:⊗4⊃% Q
*#9∪pj iq⊃*$
∩⊃3AQB""(:wptdhuTU
5∀U
$dKHIH:Stj X33tK≠s∪ph~∩3sE Q
7%∀PtSλa"B"(Y∀q#!!""0j;ptiIiq⊃.J P31+9Q↔)H:S⊃NaQB"1)h∞c"A~Q5∃*)J⊂te↔c"B(YQ∞c!!"Tu
)3Qh
Spq(J4Q(λ~u∩f
:∀R3Hu∀T∃
%∀u⊂(9j(⊂*:∩j.aQB0Q(y3C"A~u∀R)hh∀k _∞c"A→3U⊃(x4H∩%INc"A~T∃∀E t∪Q¬∀∃Nc!!21↔j:⊂0rg)1⊗p*:∩w.aQB21Dλ4u∩gY⊂4uλ~R5∩∧
∩⊃3AQB"2(KhJH∧$R1∞aQB4wij3∪∞aQB3WeV.c"A_StH ≠tu⊂(9nT⊃
p4u ;(∀uλZλ ,$
3U∩)D λ⊃ q"B"((1r3AQB"2)j⊃1q*$∀U∞aQB"2(d
∪Wiel*/F4∃∩⊃)d⊃∪sHWc"B!~wtiI_ PuJ5∪J)D'HIUλ_Nr1 tHλλG1"B"*ktu⊂(9nP6h~u∩w+97.c!!"21D¬∀U↔j(0u⊗*λ*∃J%↔3∪pe ⊃Q3
E(∃∩λYC"B!⊃4wtdj∀u∀E ⊃Q3
GV⊃Vjk*)Pj)⊃C"A⊃13∀hT∩1H
*∂3∪h5∃Q0jItJ( zH∀UπY∪pj
8p3⊂*%(∃∩λYC"B!⊃4wtdit∪Q
:∀J∃E∀PtSλa"B"(Y∀q( _H∀UπVλ∃∩λYC"B!⊃4wtddH∂λ ]<≥≡$πHλIH:S⊃C!!"13
8#"B!⊃4wtdhuTU
5∀U
$dKHIH:Stj X33tK≠s∪ph~∩3sE
J7*$htS⊃G1"B"(YQ∞c!!4Q5
ZSJ∀e↔c"B(YQ∞c!!"Tu
)3Qh
Spq(J4Q( z⊃3QI_∀nc!!0Q1i→C"B*:∀R3Ht∀nc!!4wsJY∪∞c!!21Hλ→⊂rπ&∧∃∩⊃)d∀whH→λ⊃R)H.HλDh3⊃R(DHHλ∧∧λNc!!21H
λrπ,∧
∩⊃3D
wtiD*λ⊃R)H.HλDj⊂qR(DHHλ∧∧λNc!!21H H3Qu ¬∪⊂4jI00j'fλ∃∩λYH∀wj4HS⊂*:λ∪0(:SnH∧$S⊂4jI00iD$λλλ∧'c"B*(5∃4Ie∀iPj)⊃J.aQB13HGc"@↓D(→~.>≠_>$∞[⎇=
≥Y<nD∞≤Y9#∞≤Z;NE_||C∞≤Z;NE≥<→ ≡→.c!!"R3JH1q4D 06⊃λZ∃∩∞d∧(~≠nt→→9.∧≥≠h M<|≠ ∨(≥≤L\.c"AQR3UλXq4Hλ~TP6$λ⊂U1K6.L,εε↔.c!)3U⊃(x4H⊃ I04KλJS04EH∃∪0*%⊃⊂S(~Nhλ$∞z≠{ T→~<n
_>( ≡Y8.aQR3UλXq4Hλ9∪04G4λ(_n↑\{|D
→9]∧
8<Ym≥Nc"I→U⊃1hZH⊂5 X4Nh∧∀_<Z.M≠9=
≤h→~.=≤_>$∞≠|λ
\<Yz-gc"R)j⊃1q*$⊂U∪(~Nhλ$ <Z=
9=~,4→~<mN_>(∞M|λ≠,≡Yz;G1"R3JH1q4Dλ1V∪ →Q4kλ~R5∩ I3Q4g1"R3JH1q4D
∀∃∪(~Nc"I→U⊃1hZH⊂r
*r6Q%H∀⊗0j96Q.aQC"R)j⊃1q*$⊂4TH≠(∀∀ →QU⊂IKl∞LF;.c"HH1R3HT∀∀∩)zλλVkTH∂( 4ml Fε εε ↔'1"Q⊃(i3Q(
∩3QItλVw$$∂(⊗j
∩3u∧ε+↔.aQC"PIys⊃0)d∀∀Sh81∃4HT∪sQλGc"B*:⊂4Uβλsq⊃!QB4∀ →QSb*
∩3QJHS⊗l Wc"B)YuQ"&∃∀∀∩)hU⊂S 6W.c!!5∪∪Ia,+ f⊗ επc"B*H⊗P"&∃ .c!!4q5 q,+∞aQB13HGc"B!QTr3* ⊃(∀
)pq1
ZQ(∩)i04Q(~nc"A_Q1r)a"B0i
Tr6H[ll∞d∧(∩(∞M~;Zg1"B1
0tr+(7lNaQB21D sQ⊃∧
∩⊃3AQB"0HXr3C!!"1∪ X4Wk&fM.c!!"1∀IX4Wm&V∞c"A⊃13Q↓QB13
8#"B!_Q1r)a"B"(9∀Tr+(7lLπ1"B"(I∪04Ku-,,π1"B"(JS04Kv,,∞aQB"1)h∞c"A_∃∪0*+m
,π1"B1λ)04WeV,,∞aQB0s X4Wq
)04K&⊗,∞c!!05∪(~Wq⊂IX4JjλJ∪04EX⊂S0*%+lNaQB4∀
I04WhHS04E5⊃∃∪(~K1⊂IX4J*F¬LL∞aQB0U X4Wjλ~∪04EZ∀∃∪(~J+lE:∀∃∪(~Nc"A_1V∪ →Q4weλ∃∪0*%05∪(~J+pi
Tr6HWc"B(~R5∩ I3Q4ku⊂5∪(~K0U X4J+h9∀Tr+(.c"A_3Q∞aQTQ4*Y4Q( →R04HX4h∩)i5∩0)I6P5 →sH⊗f .c"AQTr3* ⊃(∀
)pq1
ZQ(⊃
(5s∩)h*∩3JH1q4D ⊗&¬⊗ + ⊗*.c!!0Q1i→C"B(→5Q0jE⊗ + ⊗*.c!!05Q(:
⊗ ¬K,
.aQB13HGc"C!*r34 H(∀∀Ixq1∃*((⊃∀H~pSv¬ 3U⊃(x4H⊗ε¬⊗, ε+⊗,%↔c"B((1r3AQB02*h0u
ε ⊗,¬↔c"B(~Q0u¬ ⊗&∃.c"A_5Q0jE⊗ + ⊗*.c!!05Q(:
⊗ %K,
.aQB05HXu
⊗ε¬⊗,
'1"B1)h∞c"AQT∀Sh81∃4HT∃∀Q(S∀∀R)j
∀T
JJ∪ShH*(∪HE.c"A_Q1r)a"B3jZ∀u∀E
∀Q1#
u∀R)hj∪Q¬∃.c"A_3Q∞aQROCEDURE CSR_PRINT(RPTR(STACK) CSR);
OUTSTR(CSR_STRING(CSR));
PROCEDURE UPDATE;
BEGIN
IF UPDSUPPRESS>0 THEN RETURN;
DPYSET(DBUF);
DPYBIG(DPYCSIZE);
TYPLOC(PPTMAR-CHRSIZE,DBMAR);
DRAWBOX(DLMAR,DTMAR,DRMAR,PPTMAR);
DRAWLINE(CLMAR,DTMAR,CLMAR,ATMAR);
DRAWLINE(DLMAR,ATMAR,DRMAR,ATMAR);
DRAWLINE(DLMAR,BTMAR,DRMAR,BTMAR);
TXTBLK(TREE_STRING(CURTREE,0,MAXDEPTH),
DLMAR+5,DTMAR-CHRSIZE-5,
CLMAR-DLMAR-10,AFXLINES);
TXTBLK(ASTK_STRING($ASTACK),
DLMAR+5,ATMAR-CHRSIZE-5,
DRMAR-DLMAR-10,ARITHLINES);
TXTBLK(ASTK_STRING($BSTACK),
DLMAR+5,BTMAR-CHRSIZE-5,
DRMAR-DLMAR-10,ARITHLINES);
TXTBLK( OPENFIDS,
DLMAR+5,PPTMAR+10+CHRSIZE,
DRMAR-DLMAR-10,1);
IF LASTCURSOR≠NULL_RECORD THEN
TXTBLK(CSR_STRING(LASTCURSOR),
CLMAR+5,DTMAR-CHRSIZE-5,
DRMAR-CLMAR-10,AFXLINES-2);
TXTBLK("LAST λ:"&CRLF&" "&LASTλ&CRLF,
CLMAR+5,ATMAR+10+2*CHRSIZE,DRMAR-CLMAR-10,2);
DPYOUT(1);
END;
! toplevel;
REAL !π;INITIALIZE(!π←π);
PROCEDURE TOPLEVEL;
BEGIN¬
LABEL READY;
REAL NOMAC π;
PROCEDURE PUNT;
BEGIN¬
! this pRocedure is used to escape to toplevel;
GO TO READY;
END;
ESCAPE←NEW;
ASSIGN(ESCAPE,PUNT); ! we hope kick will not be blocked;
! First, some initialzations. ;
π ← !π; ! WHAT A KLUGE;
WORLD←NEW_NODE("WORLD");
ARM←NEW_NODE("ARM");
POINTER←NEW_NODE("POINTER");
FIDUCIAL←NEW_NODE("FIDUCIAL");
AFX_NODE(ARM,WORLD,NRGLNK);
AFX_NODE(POINTER,ARM,NRGLNK);
AFX_NODE(FIDUCIAL,WORLD,NRGLNK);
PUSHSTK($CURDAD,WORLD);
PUSHSTK($CURPATH,WORLD);
PUSHSTK($CURREF,WORLD);
PUSHSTK($CURMOVE,ARM);
PUSHSTK($CURTREE,WORLD);
PUSHSTK($CURNODE,WORLD);
LASTCURSOR←$CURNODE;
LASTARITH←$ASTACK;
SETFORMAT(0,3);
MAXDEPTH←999;
READARM;
DPYCLR;
DPYSET(DBUF);
TYPLOC(PPTMAR-CHRSIZE,DBMAR);
DPYOUT(1);
! now execute;
READY: UPDSUPPRESS←0;
UPDATE;
OUTSTR("BAIL is your command scanner.");
;BAIL;;
GO TO READY;
END;
! main program;
LABEL XIT;
PROCEDURE EXIT; GO TO XIT;
TOPLEVEL;
XIT: END "POINTY"